iSharkFly-Open
/
VistA-WorldVistAEHR
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

revised back to 6/30/08 version

This commit is contained in:
george 2009-12-04 05:11:15 +00:00
parent d7c01225d8
commit c02138cd3d
1724 changed files with 196085 additions and 204097 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m
View File

@ -1,8 +1,6 @@
PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM
;;4.5;Accounts Receivable;**8,67,125,169,254**;Mar 20, 1995;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
; DBIA 3820-A used for direct global read into file 399.
;
V ;;4.5;Accounts Receivable;**8,67,125,169**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;This is a routine for adjustment transaction.
NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
ADJUST D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q
@ -56,10 +54,7 @@ TI() ;
N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW"
S %DT="AERX",%DT(0)=% D ^%DT
Q Y
BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE"),PRCAIBS D BILL^PRCAUTL Q:('$D(PRCABN))
S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13) ; IB claim status - DBIA3820-A
I PRCAIBS=1 W !!,"** You cannot add AR Comments to an Entered/Not Reviewed claim. **",!,*7 G BEGIN
I PRCAIBS=2 W !!,"** You cannot add AR Comments to an MRA Request claim. **",!,*7 G BEGIN
I '$D(^PRCA(430,PRCABN,2,0)),PRCAIBS=7 W !!,"** You cannot add AR Comments to a claim Cancelled/not passed to AR. **",!,*7 G BEGIN
BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN))
I '$D(^PRCA(430,PRCABN,2,0)) W !!,"** This bill was cancelled in IB before it was passed to AR. **",!,*7 G BEGIN
I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 G BEGIN
D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m
View File

@ -1,5 +1,5 @@
PRCAGST ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement ;12/12/96 9:39 AM
V ;;4.5;Accounts Receivable;**34,181,190,249**;Mar 20, 1995;Build 2
V ;;4.5;Accounts Receivable;**34,181,190**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;ENTRY WITH DEBTOR PRINT STATEMENT
EN(DEB,TBAL,PDAT,PBAL,LDT) ;
@ -11,7 +11,7 @@ EN(DEB,TBAL,PDAT,PBAL,LDT) ;
S X=X+1,ADD(X)=$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
S X=X+1,ADD(X)=$P(ADD,U,7)
W @IOF
W !!,"Department of Veterans Affairs",?50,"Acct No.: ",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9)
W !!,"Department of Veterans Affairs",?50,"Acct No.: ",SSN
W !,$G(ADD(1))
S Y=$$FPS^RCAMFN01($S($G(LDT)>0:$E(LDT,1,5),1:$E(DT,1,5))_$TR($J($$PST^RCAMFN01(DEB),2)," ",0),$S(+$E($G(LDT),6,7)>$$STD^RCCPCFN:2,1:1)) D DD^%DT
W !,$G(ADD(2)),?50 I TBAL>0 W "Due: UPON RECEIPT"

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m
View File

@ -1,5 +1,5 @@
PRCAGST1 ;WASH-ISC@ALTOONA,PA/CMS-Print Patient Statement Bottom ;10/16/96 11:13 AM
V ;;4.5;Accounts Receivable;**2,48,104,176,249**;Mar 20, 1995;Build 2
V ;;4.5;Accounts Receivable;**2,48,104,176**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;ENTRY FROM PRCAGST PAGE 1
NEW AMT,BN,DAT,DESC,I,REF,THNK,TN,TTY,X,Y,RCTOTAL
@ -58,7 +58,7 @@ HDR ;statement transaction header
NEW I,Y
S PAGE=$G(PAGE)+1
I PAGE>1 W @IOF I $G(^RC(342,1,5))]"" F I=1:1:18 W !
W !,"Department of Veterans Affairs",?50,"Acct No.:",$P($$SITE^VASITE(),U,3)_"/"_$E(SSN,6,9)
W !,"Department of Veterans Affairs",?50,"Acct No.: ",SSN
W !,NAM,?50,"Page ",PAGE
S Y="",$P(Y,"_",80)="" W !,Y
W !,"|Date Posted|",?13," Description",?58,"| Amount ",?67,"| Reference |"

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m
View File

@ -1,5 +1,5 @@
PRCASVC ;SF-ISC/YJK-ACCEPT, AMMEND AND CANCEL AR BILL ;9/6/95 2:09 PM
V ;;4.5;Accounts Receivable;**1,21,48,90,136,138,249**;Mar 20, 1995;Build 2
V ;;4.5;Accounts Receivable;**1,21,48,90,136,138**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
REL ;Accept bill into AR
N X,Y
@ -8,7 +8,7 @@ REL ;Accept bill into AR
S DIE="^PRCA(430,",DR="[PRCASV REL]",DA=PRCASV("ARREC") D ^DIE
Q3 K PRCAT,PRCAORA,PRCADEBT,DIE,DR,%
; set the fund for the bill (set in routine rcxfmsuf)
S:'$G(DA) DA=PRCASV("ARREC") S %=$$GETFUNDB^RCXFMSUF(DA)
S %=$$GETFUNDB^RCXFMSUF(DA)
I "^27^28^"[("^"_PRCASV("CAT")_"^") D
.N P
.F P=6,8,10,15 S $P(^PRCA(430,DA,11),"^",P)=$S(P=6:1000,P=8:$G(PRCASV("SITE")),P=10:9,1:$P($G(PRCASV("FY")),"^"))

7
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m
View File

@ -1,6 +1,6 @@
RCDMC90 ;WASH IRMFO@ALTOONA,PA/TJK-DMC 90 DAY ;7/17/97 8:13 AM
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229,253**;Mar 20, 1995;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
ENTER ;Entry point from nightly process
Q:'$D(RCDOC)
;run the interest and admin for newly flagged Katrina Patients.
@ -107,9 +107,6 @@ PROC(DEBTOR,QUIT) ;PROCESS BILLS FOR A SPECIFIC DEBTOR
.;Q:$$INSURED^IBCNS1(DFN,$P(B0,U,10)) ;Commented out w/patch *121
.S X=$P(B0,U,2),X=$S(X=22:1,X=23:1,(X>2)&(X<6):2,X=18:2,X=24:2,X=25:2,X=1:3,X=2:4,(X>26)&(X<30):5,X>29:6,1:"")
.Q:X="" K CATYP(X)
.;Check if bill should be deferred from being sent to DMC if Veteran is
.;SC 50% to 100% or Receiving VA Pension (Hold Debt to DMC project, sbw)
.Q:+$$HOLDCHK^RCDMCUT1(BILL,DFN)>0
.I $P(B6,U,21),$P(B6,U,21)<ESTDT S ESTDT=$P($P(B6,U,21),".")
.I $P(B12,U,2),PRIN>$P(B12,U,2) S PRIN=$P(B12,U,2)
.S ^TMP($J,"RCDMC90","BILL",BILL)=$S($P(B12,U):$P(B12,U),1:DT)_U_PRIN_U_INT_U_ADMIN

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m
View File

@ -1,5 +1,5 @@
RCDPEM ;ALB/TMK - POST EFT, ERA MATCHING TO EFT ;05-NOV-02
;;4.5;Accounts Receivable;**173,255**;Mar 20, 1995;Build 1
;;4.5;Accounts Receivable;**173**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
; IA 4050 covers call to SPL1^IBCEOBAR
Q
@ -24,7 +24,7 @@ EN ; Post EFT deposits, auto-match EFT's and ERA's
; Post deposits for any unposted EFTs in file 344.3
; 'Unposted' EFTs have a 0 in AMOUNT POSTED field
S ^TMP($J,"RCTOT","EFT_DEP")=0
S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$P(RC0,U,8),($E($P(RC0,U,6),1,3)="469")!($E($P(RC0,U,6),1,3)="569") D
S RCZ=0 F S RCZ=$O(^RCY(344.3,"APOST",0,RCZ)) Q:'RCZ S RC0=$G(^RCY(344.3,RCZ,0)) I RC0'="",$E($P(RC0,U,6),1,3)="469",$P(RC0,U,8) D
. S ^TMP($J,"RCTOT","EFT_DEP")=^TMP($J,"RCTOT","EFT_DEP")+1
. ; Verify check sums
. S RCSUM=$$CHKSUM^RCDPESR3(RCZ)

12
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m
View File

@ -1,6 +1,6 @@
RCDPESR2 ;ALB/TMK - Server auto-upd - EDI Lockbox ;06/03/02
;;4.5;Accounts Receivable;**173,216,208,230,252**;Mar 20, 1995;Build 63
;;Per VHA Directive 2004-038, this routine should not be modified.
;;4.5;Accounts Receivable;**173,216,208,230**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
; IA 4042 (IBCEOB)
;
TASKERA(RCTDA) ; Task to upd ERA
@ -59,14 +59,14 @@ UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4
; RCFILE = 4 file 344.4, 5 if 344.5
; DUP = msg # if dup msg, but not same # or -1 if same msg #
;Returned for each bill in ERA:
;^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^SrvDt
;^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^rev flg^EEOB pn^amtbld^^^^BPNPI^RNPI^ETQual^LN^FN
; ^TMP($J,"RCDPEOB",n)=Bill ien^AR bill#^Service Date
; ^TMP($J,"RCDPEOB",n,"EOB")=EOB ien^amt pd^ins co ptr^reversal flag^pt name on EEOB^amt billed
; ^TMP($J,"RCDPEOB","ADJ",x)=adj rec ('02')
;Also:
; ^TMP($J,"RCDPEOB","HDR")=hdr rec from txmn
; ^TMP($J,"RCDPEOB","CONTACT")=ERA contact rec ('01')
;
N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCDPBNPI,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5
N RCGBL,RC,RC0,RCCT,RCCT1,RCEOB,RCBILL,RCMNUM,RCIFN,RCIB,RCERR,RCSTAR,RCET,RCX,RCXMG,Z,Q,DA,DR,DIE,RCPAYER,RCFILED,RCEOBD,RCNOUPD,REFORM,RCSD,RCERR1,C5
K ^TMP($J,"RCDP-EOB"),^TMP("RCDPERR-EOB",$J)
;
S RCPAYER="",RCFILED=1,RCNOUPD=0
@ -85,7 +85,6 @@ UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4
.S ^TMP($J,"RCDPEOB","HDR")=$G(^RCY(344.4,+RCTDA,1,+$P(RCTDA,";",2),1,1,0))
;
S RCPAYER=$P($G(^TMP($J,"RCDPEOB","HDR")),U,6)
S RCDPBNPI=$P($G(^TMP($J,"RCDPEOB","HDR")),U,18)
;
;srv dates
S RCSD=$NA(^TMP($J,"RCSRVDT")) K @RCSD
@ -118,7 +117,6 @@ UPDEOB(RCTDA,RCFILE,DUP) ;Upd 361.1 from ERA msg in 344.5 or .4
.I +RC0=10 D ;Save amt pd/billed, rev flg
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,2)=$S(+$P(RC0,U,11):$J($P(RC0,U,11)/100,"",2),1:0),$P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,6)=$J($P(RC0,U,11),"",2)
..I $P(RC0,U,6)="Y"!($P(RC0,U,7)=22) S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,4)=1
..S $P(^TMP($J,"RCDPEOB",RCCT,"EOB"),U,10,14)=RCDPBNPI_U_$P(RC0,U,16,19)
.I RCBILL=$P(RC0,U,2) S RCCT1=RCCT1+1,^TMP($J,"RCDP-EOB",RCCT,RCCT1,0)=RC0
;
S RCSTAR=$TR($J("",15)," ","*"),RCET=RCSTAR_"ERROR/WARNING EEOB DETAIL SEQ #"

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m
View File

@ -1,5 +1,5 @@
RCDPESR3 ;ALB/TMK - Server auto-update utilities - EDI Lockbox ;06/06/02
;;4.5;Accounts Receivable;**173,214,208,255**;Mar 20, 1995;Build 1
;;4.5;Accounts Receivable;**173,214,208**;Mar 20, 1995
Q
;
EFTIN(RCTXN,RCD,XMZ,RCGBL,RCEFLG) ; Adds a new EFT record to AR file 344.3
@ -71,7 +71,7 @@ ADDEFT(RCTXN,RCXMZ,RCGBL,RCERR) ; File EFT TOTAL record in file 344.3
N RCTDA,RCRCPT,RCDUP,RCHAC,Z,Z0
S (RCERR,RCTDA)=""
;
I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="569",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number
I $E($P(RCTXN,U,6),1,3)'="469",$E($P(RCTXN,U,6),1,3)'="HAC" D G ADDQ ; Invalid EFT deposit number
. N RCDXM,RCCT
. S RCCT=0
. S RCCT=RCCT+1,RCDXM(RCCT)="This EFT has an invalid deposit number for EDI Lockbox and has been rejected.",RCCT=RCCT+1,RCDXM(RCCT)=" "

16
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m
View File

@ -1,11 +1,11 @@
RCDPESR6 ;ALB/TMK - Server auto-update file 344.4 - EDI Lockbox ;10/29/02
;;4.5;Accounts Receivable;**173,214,208,230,252**;Mar 20, 1995;Build 63
;;Per VHA Directive 2004-038, this routine should not be modified.
;;4.5;Accounts Receivable;**173,214,208,230**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT
; If passed by reference, RCRTOT is returned = "" if errors
;
N RC,RCCOM1,RCCOM2,RCCT,RC1,RC2,RCDPNM,RCEOB,RCNPI1,RCNPI2,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z
N RC,RCCT,RC1,RC2,RCEOB,DA,DR,DO,DD,DLAYGO,DIC,DIK,X,Y,Z
S RC=0 F S RC=$O(^TMP($J,"RCDPEOB",RC)) Q:'RC S RC1=$G(^(RC)),RC2=$G(^(RC,"EOB")),RCEOB=+RC2 D Q:'RCRTOT
. ; Upd 344.41 with reference to this record if it doesn't already exist
. I RCEOB>0 Q:$D(^RCY(344.4,RCRTOT,1,"AC",RCEOB,RC))
@ -18,16 +18,6 @@ UPD3444(RCRTOT) ; Add EOB detail to list in 344.41 for file 344.4 entry RCRTOT
. I $P(RC2,U,3)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".04////"_$P(RC2,U,3) ; ins co
. I $P(RC2,U,4) S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".14////1" ; reversal
. I $P(RC2,U,5)'="" S DIC("DR")=DIC("DR")_$S($L(DIC("DR")):";",1:"")_".15////^S X=$E($P(RC2,U,5),1,30)" ; Patient name
. ; Process Billing Prov NPI, Rendering/Servicing NPI & name
. S (RCCOM1,RCCOM2)=""
. S RCNPI1=$P(RC2,U,10),RCNPI2=$P(RC2,U,11)
. I RCNPI1'="",'$$CHKDGT^XUSNPI(RCNPI1) S RCCOM1="The Billing Provider NPI received on the 835 ("_$E(RCNPI1,1,10)_") is not a valid format."
. I RCNPI2'="",'$$CHKDGT^XUSNPI(RCNPI2) S RCCOM2="The "_$S($P(RC2,U,12)=1:"Rendering",1:"Servicing")_" NPI received on the 835 ("_$E(RCNPI2,1,10)_") is not a valid format."
. I RCCOM1="" S DIC("DR")=DIC("DR")_";.18////^S X=$P(RC2,U,10)" ;Billing Provider NPI
. I RCCOM2="" S DIC("DR")=DIC("DR")_";.19////^S X=$P(RC2,U,11)" ;Rendering Provider NPI
. S RCDPNM=$P(RC2,U,13) I $P(RC2,U,14)]"" S RCDPNM=RCDPNM_$S(RCDPNM]"":",",1:"")_$P(RC2,U,14)
. S DIC("DR")=DIC("DR")_";.2////^S X=$P(RC2,U,12);.21////^S X=RCDPNM" ; Entity Type Qualifier ^ Last name,First Name
. S DIC("DR")=DIC("DR")_";.22////^S X=RCCOM1;.23////^S X=RCCOM2" ;Comment on Billing provider^comment on rendering/servicing provider NPI
. D FILE^DICN K DO,DD,DLAYGO,DIC,DIK
. S RCCT=+Y
. I RCCT<0 D Q

9
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m
View File

@ -1,6 +1,6 @@
RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003
;;4.5;Accounts Receivable;**173,252**;Mar 20, 1995;Build 63
;;Per VHA Directive 2004-038, this routine should not be modified.
;;4.5;Accounts Receivable;**173**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Note: if the 835 flat file changes, make the corresponding changes
; in this routine.
@ -22,7 +22,6 @@ RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003
;;835^^Last Sequence #
;;835^^Contact Information
;;835^^Payment Method Code
;;835^^Billing Provider NPI
;
01 ;;PAYER CONTACT INFORMATION
;;01^^ERA Contact Name
@ -68,10 +67,6 @@ RCDPESR9 ;ALB/TMK - ERA return file field captions ;09-SEP-2003
;;10^^DRG Code Used
;;10^^DRG Weight Used^S Y=$J($$ZERO^RCDPESR9(X,1)/100,4)
;;10^^Discharge Fraction^S Y=$$ZERO^RCDPESR9(X,1)
;;10^^Rendering NPI
;;10^^Entity Type Qualifier
;;10^^Last Name
;;10^^First Name
;
15 ;;CLAIM STATUS DATA
;;15^^Line Type^S Y=X_" (CLAIM LEVEL CLAIM STATUS DATA (CONTINUED))"

16
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m
View File

@ -1,11 +1,11 @@
RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;06 Jun 2007 11:50 AM
;;4.5;Accounts Receivable;**173,208,252**;Mar 20, 1995;Build 63
;;Per VHA Directive 2004-038, this routine should not be modified.
RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;26-NOV-02
;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
PARAMS ; Select params for ERA list
; Return ^TMP("RCERA_PARAMS",$J) array
N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT,DUOUT,DTOUT
N DIR,X,Y,RCDFR,RCDTO,RCPAYR,RCQUIT
K ^TMP("RCERA_PARAMS",$J)
S RCQUIT=0
W !!,"SELECT PARAMETERS FOR DISPLAYING THE LIST OF ERAs"
@ -44,8 +44,7 @@ PAYR S RCQUIT=0,DIR(0)="SA^A:ALL;R:RANGE",DIR("A")="(A)LL PAYERS, (R)ANGE OF PAY
. S $P(^TMP("RCERA_PARAMS",$J,"RCPAYR"),U,3)=Y
W !
;
PARAMSQ ;
D PARAMS^RCDPEWLD(.RCQUIT)
PARAMSQ I $G(RCQUIT) K ^TMP("RCERA_PARAMS",$J)
Q
;
FILTER(Y) ; Returns 1 if record in entry Y in 344.4 passes
@ -160,10 +159,9 @@ VPERA(RCSCR,RCERADET) ; Queued entry
. D GETS^DIQ(344.41,RCSCR1_","_RCSCR_",","*","IEN","RCDIQ1")
. D TXT00^RCDPEX31(RCSCR,RCSCR1,.RCDIQ1,.RCXM1,.RC)
. S RC=RC+1,RCXM1(RC-1)=$E("PATIENT: "_$$PNM4^RCDPEWL1(RCSCR,RCSCR1)_$J("",41),1,41)_"CLAIM #: "_$$BILLREF^RCDPESR0(RCSCR,RCSCR1),RCXM1(RC)=" "
. D PROV^RCDPEWLD(RCSCR,RCSCR1,.RCXM1,.RC)
. S RC3611=$P($G(^RCY(344.4,RCSCR,1,RCSCR1,0)),U,2)
. I RCERADET D
.. I 'RC3611 D Q
. I RCERADET D ; Include formatted txt from 361.1 or 344.411
.. I 'RC3611 D Q ; Formatted raw data
... D DISP^RCDPESR0("^RCY(344.4,"_RCSCR_",1,"_RCSCR1_",1)","^TMP($J,""RC_SUMRAW"")",1,"^TMP($J,""RC_SUMOUT"")",75,1)
..;
.. E D ; Detail record is in 361.1

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m
View File

@ -1,5 +1,5 @@
RCDPEX32 ;ALB/TMK - ELECTRONIC EOB EXCEPTION PROCESSING - FILE 344.4 ;10-OCT-02
;;4.5;Accounts Receivable;**173,249**;Mar 20, 1995;Build 2
;;4.5;Accounts Receivable;**173**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EDITNUM ; Edit invalid claim # to valid, refile EOB
@ -47,7 +47,7 @@ EDITNUM ; Edit invalid claim # to valid, refile EOB
.. I $P(Q0,U,2)=$P(RC0,U,5) S $P(Q0,U,2)=RCBILL(1)
.. S ^TMP($J,"RCDP-EOB",1,Q,0)=Q0
. S ^TMP($J,"RCDP-EOB",1,.5,0)="835ERA"
. S RCEOB=$$DUP^IBCEOB("^TMP("_$J_",""RCDP-EOB"",1)",RCBILL) ; IA 4042
. S RCEOB=$$DUP^IBCEOB(RCBILL,"^TMP("_$J_",""RCDP-EOB"",1)") ; IA 4042
. K ^TMP($J,"RCDP-EOB",1,.5,0)
. I RCEOB D Q
.. N RCWHY S RCWHY(1)="EEOB already found on file while trying to change claim # and filing into IB"

18
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m
View File

@ -1,6 +1,6 @@
RCDPUDEP ;WISC/RFJ-deposit utilities ;29/MAY/2008
;;4.5;Accounts Receivable;**114,173,257**;Mar 20, 1995;Build 3
;;Per VHA Directive 2004-038, this routine should not be modified.
RCDPUDEP ;WISC/RFJ-deposit utilities ;1 Jun 99
;;4.5;Accounts Receivable;**114,173**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
@ -63,10 +63,8 @@ LOOKUP ; special lookup on deposits, called from ^dd(344.1,.01,7.5)
I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,12)=1" S X="?" Q
; user entered C.? for lookup on confirmed deposits
I X["C."!(X["c.") S DIC("S")="I $P(^(0),U,12)=3" S X="?" Q
; deposit ticket # manually added is for electronic ticket only
I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X="" Q
; Do not allow for 7-, 8-, or 9-digit electronic ticket to be added.
I $G(DIC(0))["L",'$D(^RCY(344.1,"B",X)),$L(X)>6,$L(X)<10 D EN^DDIOL(" ** Deposit # of "_$L(X)_" digits not allowed. "_$S($L(X)=9:"9 digits limited to automatic deposits.",1:""),,"!") S X="" Q
; deposit ticket # manually entered is for electronic ticket only
I $G(DIC(0))["L",$$AUTODEP(X) D EN^DDIOL(" ** Deposit #'s starting with "_$E(X,1,3)_" can only be used by automatic deposits",,"!") S X=""
K DIC("S")
Q
;
@ -110,11 +108,9 @@ TOTAL(RCDEPTDA) ; compute total dollars for all receipts on the deposit
Q +$G(TOTAL)
;
AUTODEP(X) ; Function returns 1 if the deposit ticket # in X is in the auto
; deposit number space 269xxx, 369xxx, 469xxx, 569xxx, or 669xxx
; and hasn't been previously entered via lockbox interface.
;
; deposit number space 269xxx, 369xxx, 469xxx, 569xxx
N Y
S Y=0
I $L(X)=6,$E(X,2,3)="69","23456"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1
I $L(X)=6,$E(X,2,3)="69","2345"[$E(X),'$D(^RCY(344.1,"B",X)) S Y=1
Q Y
;

11
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m
View File

@ -1,5 +1,5 @@
RCFMOBR ;WASH-ISC@ALTOONA,PA/RWT-BILL RECONCILIATIONS LIST ;11/20/96 2:30 PM
V ;;4.5;Accounts Receivable;**2,20,40,53,249**;Mar 20, 1995;Build 2
V ;;4.5;Accounts Receivable;**2,20,40,53**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
EN ;Creates report from OBR data in file 423.6
;
@ -74,14 +74,9 @@ EN2 ;Entry point from Regenerate Prior Month OBRs option
;
EN3 ;Deletes OBRs over 60 days old
N A0,A1,A2,DA,DIK,X,X1,X2
S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=$E($P(A0,"-",2),1,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D
.S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
S A0="OBR-" F S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-") S A1=2_$E($P(A0,"-",2),3,8),A2=0 F S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0 D
.S X1=DT,X2=A1 D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
Q
RCDT(A1) ;Convert yyyymmdd to FM date
N X,Y
S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4)
D ^%DT
Q Y
PURGE ;purge unprocessed document file
N DIR,Y,X,X1,X2,RCDT
S DIR("A")="How many days worth of DATA do you want to retain"

34
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCMSITE.m
View File

@ -1,6 +1,6 @@
RCMSITE ;ALB/RRG - EDIT SITE PARAMETERS ;03/12/02
V ;;4.5;Accounts Receivable;**173,236,253**;Mar 20, 1995;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
V ;;4.5;Accounts Receivable;**173,236**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
BEG ;Start editing site paramters
N DIC,DLAYGO,X,Y,DIE,DA,DR
S DIC="^RC(342,",DIC(0)="QEAML",DLAYGO=342 D ^DIC I Y>0 S DA=+Y,DR=.01,DIE="^RC(342," D ^DIE
@ -49,33 +49,3 @@ EDILOCK ;Update EDI Lockbox site parameters
S DA=1,DR="[RCMS EDI LOCKBOX]",DIE="^RC(342," D ^DIE
Q5 Q
;
EDITRDDT ;Update # OF DAYS FOR RD ELIG CHG RPT site parameter
;This is the number of days for the Rated Disability Eligibility
;Change Report to be used when the report is scheduled to be run
;on a recurring basis. (Added for Hold Debt to DMC Project)
N DIE,DR,DA,Y
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q6
S DA=1,DR="8.01",DIE="^RC(342," D ^DIE
Q6 Q
;
GETRDDAY() ;Return # OF DAYS FOR RD ELIG CHG RPT site parameter
Q $$GET1^DIQ(342,1_",",8.01)
;
EDITRDAY ;Update NUMBER OF DAYS FOR DMC REPORTS site parameter.
;This is the number of days in the past bills for episodes
;of care will be included for the following reports when scheduled by
;IRM to be run on a recurring basis:
; DMC Debt Validity Report
; DMC Debt Validity Management Report
; Rated Disability Eligibility Change Report
;The minimum value for this field is 365 days (1 year) and the maximum
;value is 3650 days (10 years). If no value is added in this field the
;report will default to 365 days. (Added for Hold Debt to DMC Project)
N DIE,DR,DA,Y
I '$D(^RC(342,1,0)) D BEG G:'$D(^RC(342,1,0)) Q7
S DA=1,DR="8.02",DIE="^RC(342," D ^DIE
Q7 Q
;
GETRDAY() ;Return NUMBER OF DAYS FOR DMC REPORTS site parameter
Q $$GET1^DIQ(342,1_",",8.02)
;

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m
View File

@ -1,5 +1,5 @@
RCRCXM1 ;ALB/CMS - AR/RC ORIGINAL TRANSMISSION SET ;09/08/97
V ;;4.5;Accounts Receivable;**63,122,189,249**;Mar 20, 1995;Build 2
V ;;4.5;Accounts Receivable;**63,122,189**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
Q
@ -39,7 +39,7 @@ IBS ;Set the IB Bill Information data line from RCRCVXM
S ^TMP("RCRCVL",$J,"XM",PRCABN,1,2)="BN2^"_$G(RCIB("TCG"))_U_$G(RCIB("DFP"))_U_$G(RCIB("TAX"))_U_$G(PRCA("REF REASON"))
S ^TMP("RCRCVL",$J,"XM",PRCABN,2,1)="BINS^"_$P($G(RCIB("PIN")),U,5)_U_$P($G(RCIB("PIN")),U,6)_U_$P($G(RCIB("PIN")),U,7)_U_$S($G(RCIB("CRE"))]"":RCIB("CRE"),$G(RCIB("CRA"))]"":RCIB("CRA"),$G(RCIB("CRO"))]"":RCIB("CRO"),1:"")
S ^TMP("RCRCVL",$J,"XM",PRCABN,3,1)="PAT^"_$E($G(VADM(1),RCUNK),1,30)_U_$P($G(VADM(2)),U,1)_U_$P($G(VADM(3)),U,1)_U_$P($G(VADM(5)),U)_U_$G(RCIB("SR"))_U_$G(VAPA(1))_U_$G(VAPA(2))_U_$G(VAPA(3))_U_$G(VAPA(4))_U_$P($G(VAPA(5)),U,2)_U_+$G(VAPA(6))
S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),U,2,4)
S ^TMP("RCRCVL",$J,"XM",PRCABN,4,1)="INS^"_$P($G(RCIB("PIN")),U,1)_U_$G(RCIB("PIN","MMA"))_U_$P($G(RCIB("PIN")),2,4)
;
; - set multiples if defined
I $O(RCIB("OPV",0)) S RCI=0 F S RCI=$O(RCIB("OPV",RCI)) Q:'RCI D

22
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m
View File

@ -1,6 +1,5 @@
RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;;4.5;Accounts Receivable;**201,228**;Mar 20, 1995
;
Q
EN ; Entry Point
@ -28,16 +27,15 @@ FILE ;
I $G(^TMP($J,RCXVBLN,"3-399A"))'="" W "399:"_^TMP($J,RCXVBLN,"3-399A")_RCXVU_^TMP($J,RCXVBLN,"3-399B")_RCXVU_^TMP($J,RCXVBLN,"3-399C")_RCXVU_^TMP($J,RCXVBLN,"3-399D"),!
S RCXVPC=0
F S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC)) Q:'RCXVPC D
. I $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))'="" D
.. W "399.0304:"
.. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
.. W RCXVU
.. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D
... I RCXVCP>1 W "~"
... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
... Q
.. W !
. I $G(^TMP($J,RCXVBLN,"4-399B",RCXVPC))'="" W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
. W "399.0304:"
. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
. W RCXVU
. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))) D
. . I RCXVCP>1 W "~"
. . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
. . Q
. W !
. I $D(^TMP($J,RCXVBLN,"4-399B",RCXVPC)) W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
. Q
S RCXVI=""
F S RCXVI=$O(^TMP($J,RCXVBLN,"5-350A",RCXVI)) Q:RCXVI="" D

50
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m
View File

@ -1,5 +1,5 @@
RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
;;4.5;Accounts Receivable;**201,227,228,248,251,256**;Mar 20, 1995;Build 6
;;4.5;Accounts Receivable;**201,227,228,248,251**;Mar 20, 1995;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Procedures
@ -7,13 +7,11 @@ RCXVDC4 ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
D399PC ;
I RCXVD0="" Q
N RCXVD,RCXVDA,RCXVB,RCXVPC,RCXVP1,RCXVP2,RCXVP3,RCXVMULT
N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI,RCXVCNT,RCXVMH
N RCXVDT3,RCXVCP,RCXVPCDT,RCXVPS1,RCXVPS2,RCXVPS,RCXVPSER,RCXVNPI
;RCXVPC=PROC. CODE IEN, RCXVCP=CPT CODE IEN
; LOOP THRU PROC.
S RCXVMH="",(RCXVPC,RCXVCNT)=0
F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA
S RCXVPC=0
F S RCXVPC=$O(^DGCR(399,RCXVD0,"RC",RCXVPC)) Q:'RCXVPC D D39942
F S RCXVPC=$O(^DGCR(399,RCXVD0,"CP",RCXVPC)) Q:'RCXVPC D D399PCA
Q
D399PCA ;
S RCXVD=$G(^DGCR(399,RCXVD0,"CP",RCXVPC,0)) Q:RCXVD=""
@ -42,7 +40,7 @@ D399PCA ;
. Q
;provider^provider npi^specialty^service/section
S RCXVDA=RCXVDA_RCXVU_RCXVP2_RCXVU_RCXVNPI_RCXVU_RCXVPS_RCXVU_RCXVPSER
S RCXVCNT=RCXVCNT+1,^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=RCXVDA
S ^TMP($J,RCXVBLN,"4-399A",RCXVPC)=RCXVDA
; LOOP THRU CPT
S RCXVCP=0,RCXVMULT=0
F S RCXVCP=$O(^DGCR(399,RCXVD0,"CP",RCXVPC,"MOD",RCXVCP)) Q:'RCXVCP D
@ -53,43 +51,19 @@ D399PCA ;
. Q:RCXVP1=""
. S RCXVMULT=RCXVMULT+1
. S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1)
. S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2
. S ^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVMULT)=RCXVP2
. Q
;
; *256 - loop through 399.042 to find CPT procedure
MATCH N RCXVCPT1,RCXVFND,X
S RCXVCPT1=$P(RCXVD,";",1) ;proc
S (RCXVFND,RCXVCP)=0
F S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND D
. Q:$F(RCXVMH,";"_RCXVCP) ;quit if CPT proc match
. S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0))
. Q:RCXVD1=""
. S X=$P(RCXVD1,U,6) ;CPT proc
. I RCXVCPT1'="",X'="",RCXVCPT1=X D
.. S RCXVFND=1
.. S X=$P(RCXVD1,U)
.. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
.. S X=$P(RCXVD1,U,6)
.. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
.. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
.. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
.. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
.. S RCXVMH=RCXVMH_";"_RCXVCP
I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=""
Q
;
D39942 ; charge
D39942 ; CHARGES FROM 399.042
; LOOP THRU 399.042
N X
Q:$F(RCXVMH,";"_RCXVPC)
S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0))
Q:RCXVD1=""
I RCXVD1="" Q
S X=$P(RCXVD1,U)
S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
S RCXVDB=RCXVDB_RCXVU_"" ;No CPT proc
S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt
S X=$P(RCXVD1,U,6)
S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
S RCXVCNT=RCXVCNT+1
S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=""
S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
S ^TMP($J,RCXVBLN,"4-399B",RCXVPC)=RCXVDB
Q
;

4
r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m
View File

@ -1,5 +1,5 @@
RCXVFTP ;DAOU/ALA-FTP AR Data Extract Batch Files ;08-SEP-03
;;4.5;Accounts Receivable;**201,256**;Mar 20, 1995;Build 6
;;4.5;Accounts Receivable;**201**;Mar 20, 1995
;
;**Program Description**
; This code will ftp a batch file
@ -31,7 +31,7 @@ ARC ; Directly FTP to the Boston Allocation Resource Center
;
I $$GET1^DIQ(342,"1,",20.06,"I")'="P" D
. S RCXVIP="MORPHEUS.ARC.MED.VA.GOV"
. S RCXVUSR="cbotest1"
. S RCXVUSR="cbotest"
. S RCXVPAS="1qaz2wsx"
;
I RCXVSYS="VMS" D ^RCXVFTV

5
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m
View File

@ -1,8 +1,8 @@
GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ; 10/1/92
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
EN1 ;This is the main entry point for this program
D EN1^GMRACMR G:GMRAOUT EXIT
DEV ; *** Select output device, force queuing
DEV ; *** Select output device, force queueing
S GMRAZIS=""
S:GMRASEL'="1," GMRAZIS="Q"
W !! D DEV^GMRAUTL I POP S GMRAOUT=1 G EXIT
@ -30,7 +30,6 @@ PRINT ;PRINT THE DATE
.W !!,?10,$S(GMRA="W":"WARD",GMRA="M":"MODULE",GMRA="C":"CLINIC",1:"UNKNOWN"),": ",$P(^SC(GMRAX,0),U)
.S GMRACNT=0
.S GMRADATE=0 F S GMRADATE=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE)) Q:GMRADATE="" S (GMRAFLG,GMRADFN)=0 F S GMRADFN=$O(^TMP($J,"GMRAWC",GMRAX,GMRADATE,GMRADFN)) Q:GMRADFN<1 D Q:GMRAOUT
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
..S GMRAI=0 F S GMRAI=$O(^GMR(120.8,"B",GMRADFN,GMRAI)) Q:GMRAI<1 D Q:GMRAOUT
...Q:'$D(^GMR(120.8,GMRAI,0)) Q:$P($G(^GMR(120.86,GMRADFN,0)),U,2)'=1
...Q:$D(^GMR(120.8,GMRAI,"ER"))

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m
View File

@ -1,5 +1,5 @@
GMRADSP5 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES TO SIGNED OFF ALLERGIES ; 8/16/92
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
EN1 ; Entry to PATIENT ALLERGIES NOT SIGNED OFF option
S GMRAOUT=0
S GMRAHEAD(1)=$J("ALLERGY/ADVERSE REACTIONS TO BE SIGNED OFF",59),GMRAHEAD(4)=$J("ORIGINATOR",10)_$J("PATIENT",21)_$J("ALLERGY",19)_$J("ORIGINATION DATE/TIME",29),(GMRAHEAD(3),GMRAHEAD(5),GMRAHEAD(6))="",$P(GMRAHEAD(5),"-",81)=""
@ -13,7 +13,6 @@ EN2 S (GMRAORG,GMRADT)=""
Q
EN2A S GMRATEMP=$G(^GMR(120.8,GMRAREC,0)) Q:GMRATEMP=""
I '$D(^XUSEC("GMRA-ALLERGY VERIFY",DUZ)) Q:$P(GMRATEMP,U,5)'=DUZ
Q:'$$PRDTST^GMRAUTL1($P(GMRATEMP,U)) ;GMRA*4*33 Exclude test patient if production or legacy environment.
S DFN=$P(GMRATEMP,U) D PID^VADPT6 S GMRASSN=VA("BID") D KVA^VADPT
I $P(GMRATEMP,U,5)'="" S ^TMP($J,"GMRADSP",$P(^VA(200,$P(GMRATEMP,U,5),0),U),$P(GMRATEMP,U,5),$P(GMRATEMP,U,4),$P(GMRATEMP,U),GMRAREC)=$P(GMRATEMP,U,2)_U_$E($P(^DPT($P(GMRATEMP,U),0),U),1,14)_"("_GMRASSN_")"
Q

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m
View File

@ -1,5 +1,5 @@
GMRAEF2 ;HIRMFO/WAA-FDA EXCEPTION REPORT ;11/29/95 15:01
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
EN1 ; Entry to PRINT ALL FDA EXCEPTIONS WITHIN A D/T RANGE option
S GMRAOUT=0 K DIR
S DIR(0)="DO^:DT:ETX",DIR("A")="Select Start Date"
@ -20,7 +20,6 @@ EN2 ;
.I '$P(GMRA(0),U,12) Q
.I $$CMPFDA^GMRAEF1(GMRAIEN) Q
.S GMRDFN=$P(GMRA(0),U)
.Q:'$$PRDTST^GMRAUTL1(GMRDFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
.S ^TMP($J,"GMRAEF",GMRDFN,GMRABGDT)=GMRAIEN
.Q
D EN1^GMRAEF

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m
View File

@ -1,5 +1,5 @@
GMRAFDA3 ;HIRMFO/WAA-DISPLAY FDA REPORT OVER DT RANGE ;12/1/95 11:34
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
EN1 ; Entry for PRINT ALL FDA EVENTS WITHIN D/T RANGE option
S GMRAOUT=0 K DIR
S DIR(0)="DO^:NOW:EXT",DIR("A")="Select Start Date/Time"
@ -40,7 +40,6 @@ PRINT ;Central Print
.S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)=""
.S GMRAPA(0)=$G(^GMR(120.8,$P(GMRAPA1(0),U,15),0)) Q:GMRAPA(0)=""
.S DFN=$P(GMRAPA(0),U) D PID^VADPT6
.Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
.S GMRACNT=GMRACNT+1
.W !,$E($P(^DPT(DFN,0),U),1,23)," (",VA("PID"),")" K VA,DFN
.W ?32,$E($P(GMRAPA(0),U,2),1,28)

7
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAGUI1.m
View File

@ -1,5 +1,5 @@
GMRAGUI1 ;SLC/DAN - CPRS GUI support ;11/17/06 09:50
;;4.0;Adverse Reaction Tracking;**21,25,36,38**;Mar 29, 1996;Build 2
GMRAGUI1 ;SLC/DAN - CPRS GUI support ;7/13/06 14:32
;;4.0;Adverse Reaction Tracking;**21,25,36**;Mar 29, 1996;Build 9
;
Q
EN1 ; GETREC, cont'd
@ -50,7 +50,6 @@ EIE(GMRAIEN,GMRADFN,GMRARRAY) ;Mark individual entry as entered in error
D INP^VADPT S X=$$FIND1^DIC(101,,"BX","GMRA ENTERED IN ERROR")_";ORD(101,"
D:X EN^XQOR ;Process protocols hanging off of "entered in error" protocol
L -^XTMP("GMRAED",GMRADFN)
S ORY=0_$S(+$G(GMRAPN)>0:("^"_+$G(GMRAPN)),1:"") ;38 Return IEN of progress note if created
Q
;
ADCOM(ENTRY,TYPE,GMRACOM) ;Add comments to allergies
@ -144,7 +143,7 @@ UPDATE(GMRAIEN,DFN,GMRARRAY) ;Add/edit allergies
..I $G(@GMRARRAY@("GMRATYPE"))["D" S GMRAPA=GMRAIEN D EN1^GMRAPTB ;21 Send med-watch update
.S GMRAAR=$P($G(@GMRARRAY@("GMRAGNT")),U,2),GMRAPA=GMRAIEN
.D EN1^GMRAOR9 S ^TMP($J,"GMRASF",1,GMRAPA)="" D RANGE^GMRASIGN(1) ;add ingredients/classes send appropriate bulletins
S ORY=0_$S(+$G(GMRAPN)>0:("^"_+$G(GMRAPN)),1:"") ;38 If note was created send back IEN
S ORY=0
L -^XTMP("GMRAED",DFN)
Q
;

6
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPET0.m
View File

@ -1,5 +1,5 @@
GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;11/17/06 10:27
;;4.0;Adverse Reaction Tracking;**6,17,21,20,38**;Mar 29, 1996;Build 2
GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;4/7/06 12:38
;;4.0;Adverse Reaction Tracking;**6,17,21,20**;Mar 29, 1996;Build 1
EN1(GMRADFN,GMRAPA,GMRACT,GMRAOUT) ;
; ENTRY TO PERFORM ALL OF THE TASKS NECESSARY FOR
; A PROGRESS NOTE TO BE ENTERED BY ART
@ -57,7 +57,7 @@ EN1(GMRADFN,GMRAPA,GMRACT,GMRAOUT) ;
D EXIT
Q
EXIT ; Clean up of variables
K ^TMP("TIUP",$J),GMRALOC,GMRAHLOC,GMRADUZ ;38 Removed variable GMRAPN from list of variables to kill
K ^TMP("TIUP",$J),GMRAPN,GMRALOC,GMRAHLOC,GMRADUZ
Q
ASK ; Simple file manager query for a location in file 44
N DIC

5
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m
View File

@ -1,5 +1,5 @@
GMRAPFT ;HIRMFO/WAA- PRINT FDA REACTION BY DATE ENTERED/TRACKED ;4/10/97 09:30
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -30,7 +30,6 @@ PRINT ;Queue point for report
..D HEAD Q:GMRAOUT
..S (GMRAPID,GMRANAME,GMRALOC)=""
..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U)
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy system.
..D VAD^GMRAUTL1(GMRADFN,GMRADDT,.GMRALOC,.GMRANAME,"",.GMRAPID)
..I GMRALOC="" S GMRALOC="OUT PATIENT"
..E S GMRALOC=$P($G(^DIC(42,GMRALOC,0)),U)
@ -46,7 +45,7 @@ PRINT ;Queue point for report
..W ?32,"Trk DT: ",$$FMTE^XLFDT($P(GMRAPA1(0),U,18),"2D") ; Tracking Date
..W ?49,$E($G(GMRARAC(2)),1,30) ; The 2nd reaction that is listed
..W !,"Loc: ",GMRALOC
..W ?32,"-------------" ; Separator
..W ?32,"-------------" ; Seperator
..W ?49,$E($G(GMRARAC(3)),1,30) ; The 3rd reaction that is listed
..W !,"Obs: ",$P($G(^VA(200,$P(GMRAPA1(0),U,19),0)),U) ; User entered
..D

7
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m
View File

@ -1,7 +1,7 @@
GMRAPL ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION ;5/2/97 14:13
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
EN1 ; This routine will loop through the GMRA patient allergy file
; to find all patient within the date range that meet the criteria
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop thourgh the GMRA patient allergy file
; to find all patient within the date range that meet the critera
; and then display all the data for those patients first by location
; then by date/time range of the reaction.
; First select a starting date.
@ -31,7 +31,6 @@ GET ; This sub routine is to find all the reaction with in this observed
..; Get patient name and location.
..S GMRATYP=$P(GMRAPA(0),U,20) ; Get the reaction types FDO
..S (GMRANAM,GMRALOC,GMRAVIP)=""
..Q:'$$PRDTST^GMRAUTL1($P($G(GMRAPA(0)),U)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment
..D VAD^GMRAUTL1($P(GMRAPA(0),U),$P(GMRAPA(0),U,4),.GMRALOC,.GMRANAM,"","","","",.GMRAVIP)
..I GMRALOC'="",+$G(^DIC(42,GMRALOC,44)) S GMRALOC=$P($G(^SC(+$G(^DIC(42,GMRALOC,44)),0)),U)
..I GMRALOC="" S GMRALOC="Out Patients"

5
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m
View File

@ -1,11 +1,11 @@
GMRAPNA ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;12/1/95 14:15
;;4.0;Adverse Reaction Tracking;**30,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**30**;Mar 29, 1996
EN1 ; Entry for LIST BY LOCATION OF UNDOCUMENTED ALLERGIES option
D EN1^GMRACMR G:GMRAOUT EXIT
D DEV
D EXIT
Q
DEV ; *** Select output device, force queuing
DEV ; *** Select output device, force queueing
;***** NOTE: CHECKS TO SEE IF VALID DEVICE IS SELECTED THEN ALL I HAVE TO DO IS RUN TASK MAN.
S GMRAZIS="" S:GMRASEL'="1," GMRAZIS="Q"
W !! D DEV^GMRAUTL I POP G EXIT
@ -36,7 +36,6 @@ PRINT ;PRINT THE DATE
..E I +$P(^GMR(120.86,GMRADFN,0),U,4)<$G(GMRAED,9999999) Q
..Q:'$D(^DPT(GMRADFN,0))
..Q:$$DECEASED^GMRAFX(GMRADFN) ;GMRA*4*30 Prevent deceased patients from appearing on this report.
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
..S GMRACNT=GMRACNT+1
..W !,$P(^DPT(GMRADFN,0),U) S DFN=GMRADFN,VAINDT=$S(GMRADATE="CURRENT":DT,1:GMRADATE) D 1^VADPT W ?30,VA("PID") W:GMRA'="C" ?45,$P(VAIN(2),U,2)
..I VAIN(5)'="" W !,?5,"Room/Bed: ",VAIN(5)

5
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m
View File

@ -1,5 +1,5 @@
GMRAPST1 ;HIRMFO/WAA- PRINT LISTING OF FATAL REACTIONS ;3/5/97 14:45
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries where the patient has died.
S GMRAOUT=0
@ -30,7 +30,6 @@ PRINT ;Queue point for report
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;data entered in error
..Q:$P(GMRAPA1(0),U,3)'="y" ; If patient did not die of the reaction
..S GMRADFN=$P(GMRAPA1(0),U,2),GMRADDT=$P(GMRAPA1(0),U) ; reaction date
..Q:'$$PRDTST^GMRAUTL1(GMRADFN) ;GMRA*4*33 Exclude test patient from report in production or legacy environments.
..S (GMRAPID,GMRANAME)=""
..D VAD^GMRAUTL1(GMRADFN,GMRADDT,"",.GMRANAME,"",.GMRAPID)
..S GMRADIED=$P($G(^DPT(GMRADFN,.35)),U) ; Date patient died
@ -67,7 +66,7 @@ PRINT ;Queue point for report
.Q
D CLOSE^GMRAUTL
Q
;has the patient died within the date
;has the patient died with inthe dat
HEAD ; Print header information
I GMRAPG'=1 Q:$Y<(IOSL-4)
I $E(IOST,1)="C" D Q:GMRAOUT

7
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m
View File

@ -1,5 +1,5 @@
GMRAPST2 ;HIRMFO/WAA- PRINT SUM LISTING OF OUT COMES ;3/5/97 14:50
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -27,7 +27,6 @@ PRINT ;Queue point for report
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error data
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
..S GMRATOT=GMRATOT+1
..F GMRALAB=1:1 S GMRALINE=$T(TEXT+GMRALAB) Q:$P(GMRALINE,";",3)="" D
...S GMRAP=$P(GMRALINE,";",4)
@ -57,7 +56,7 @@ PRINT ;Queue point for report
W !!,?22,"Total number of records processed ",GMRATOT
D CLOSE^GMRAUTL
Q
;has the patient died within the date
;has the patient died with inthe dat
HEAD ; Print header information
I GMRAPG'=1 Q:$Y<(IOSL-4)
I $E(IOST,1)="C" D Q:GMRAOUT
@ -77,7 +76,7 @@ HEAD ; Print header information
S GMRAPG=GMRAPG+1
I $D(ZTQUEUED) S:$$STPCK^GMRAUTL1 GMRAOUT=1 ; Check if stopped by user
Q
TEXT ;;these are the labels that will denote the field data
TEXT ;;these are the labeles that will denote the field data
;;Patients that Died: ;3
;;Reactions treated with RX drugs: ;4
;;Life Threatening illness: ;5

5
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m
View File

@ -1,5 +1,5 @@
GMRAPST3 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY REACT ;3/5/97 15:14
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -30,7 +30,6 @@ PRINT ;Queue point for report
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
..S GMRATOT=GMRATOT+1
..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""
@ -59,7 +58,7 @@ PRINT ;Queue point for report
W !!,?22,"Total number of records processed ",GMRATOT
D CLOSE^GMRAUTL
Q
;has the patient died within the date
;has the patient died with inthe dat
HEAD ; Print header information
I GMRAPG'=1 Q:$Y<(IOSL-4)
I $E(IOST,1)="C" D Q:GMRAOUT

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m
View File

@ -1,5 +1,5 @@
GMRAPST4 ;HIRMFO/WAA- PRINT FREQUENCY OF DIST OVR DT BY DC ;3/5/97 15:15
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -29,7 +29,6 @@ PRINT ;Queue point for report
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in error data
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
..S GMRATOT=GMRATOT+1
..S GMRAPA=$P(GMRAPA1(0),U,15) Q:'GMRAPA
..S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)) Q:GMRAPA(0)=""

5
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m
View File

@ -1,5 +1,5 @@
GMRAPST5 ;HIRMFO/WAA- PRINT TOTAL NUMBER OF REPORTED REACTION ;3/5/97 15:16
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -27,7 +27,6 @@ PRINT ;Queue point for report
.S GMRAPA1=0 F S GMRAPA1=$O(^GMR(120.85,"B",GMRADATE,GMRAPA1)) Q:GMRAPA1<1 D
..S GMRAPA1(0)=$G(^GMR(120.85,GMRAPA1,0)) Q:GMRAPA1(0)="" ;Bad Node
..Q:+$G(^GMR(120.8,$P(GMRAPA1(0),U,15),"ER")) ;Entered in Error Data
..Q:'$$PRDTST^GMRAUTL1($P(GMRAPA1(0),U,2)) ;GMRA*4*33 Exclude test patient from report if production or legacy environment.
..S GMRATOT=GMRATOT+1
..Q
.Q
@ -37,7 +36,7 @@ PRINT ;Queue point for report
W !,?27,"From: ",$$FMTE^XLFDT(GMAST,"2D"),?42,"To: ",$$FMTE^XLFDT(GMAEN,"2D")
D CLOSE^GMRAUTL
Q
;has the patient died within the date
;has the patient died with inthe dat
HEAD ; Print header information
I GMRAPG'=1 Q:$Y<(IOSL-4)
I $E(IOST,1)="C" D Q:GMRAOUT

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m
View File

@ -1,5 +1,5 @@
GMRAPST6 ;HIRMFO/WAA- ADR OUTCOME REPORT ;3/5/97 15:16
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -33,7 +33,6 @@ PRINT ;Queue point for report
..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;entered in error data
..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent
..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9)
..Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patients if production or legacy environment.
..S ^TMP($J,"GMRAPST6",GMRADDT,GMRACA,GMRAPA1)=""
..Q
.Q

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m
View File

@ -1,5 +1,5 @@
GMRAPST7 ;HIRMFO/WAA- ADVERSE DRUG REACTION REPORT ;3/5/97 15:17
;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
EN1 ; This routine will loop through the ADT entry point to get all
; the entries in that date range.
S GMRAOUT=0
@ -34,7 +34,6 @@ PRINT ;Queue point for report
..Q:+$G(^GMR(120.8,GMRAPA,"ER")) ;Entered in error data
..S GMRACA=$P(GMRAPA(0),U,2) ; Causative Agent
..S DFN=$P(GMRAPA(0),U),GMRACA=$E(GMRACA,1,22)_"-"_$E($P(^DPT(DFN,0),U),1)_$E($P(^(0),U,9),6,9)
..Q:'$$PRDTST^GMRAUTL1(DFN) ;GMRA*4*33 Exclude test patients from report if production or legacy environment.
..S ^TMP($J,"GMRAPST7",GMRADDT,GMRACA,GMRAPA1)=GMRAPA
..Q
.Q

3
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m
View File

@ -1,5 +1,5 @@
GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ; 8/27/93
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
EN1 ; This routine will loop through the GMRA patient allergy file (120.8)
; to find all patients with unverified reactions
;
@ -66,7 +66,6 @@ FIND ; This subroutines will build the data for the report.
F S GMADFN=$O(^GMR(120.8,"AVER",GMADFN)) Q:GMADFN<1 D
.N GMRALOC,GMRANAM,GMALOC,GMRAPA
.S GMRANAM="",GMRALOC=""
.Q:'$$PRDTST^GMRAUTL1(GMADFN) ;GMRA*4*33 Exclude test patients if production or legacy environment.
.D VAD^GMRAUTL1(GMADFN,"",.GMRALOC,.GMRANAM,"","","") I GMRALOC="" S GMALOC="OUTPATIENT"
.E S GMALOC=$P($G(^DIC(42,GMRALOC,0)),U)
.Q:GMALOC=""

16
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m
View File

@ -1,9 +1,5 @@
GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ; 12/04/92
;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
;
; Reference to $$PROD^XUPROD supported by DBIA 4440
; Reference to $$TESTPAT^VADPT supported by DBIA 3744
;
;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
Q
STPCK() ; This is to check to see if the user wanted to stop the print
S ZTSTOP=0
@ -46,16 +42,6 @@ LP1 ; Main loop
.Q
D CLOSE^GMRAUTL
Q
PRDTST(GMRADFN) ; GMRA*4*33 - Remove Test Patients from Live Reports
; This function will return 0 if the patient should not print on the report, and 1 if the patient
; should appear on the report. This function will allow all patients to print on the report if the
; report is run in a test environment.
;
I GMRADFN="" Q 0 ;DFN not defined. Should never be the case.
I '$$PROD^XUPROD() Q 1 ;Not a production or legacy environment. Print all patients on report.
I $$TESTPAT^VADPT(GMRADFN) Q 0 ;Production or legacy environment. Test patient. Do not print on report.
Q 1 ;Production or legacy environment. Not a test patient. Print on report.
;
VAD(DFN,DAT,LOC,NAM,SEX,SSN,RB,PRO,PID) ; Call to VADPT
; This call is a generic call to 1^VADPT
; Input:

7
r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m
View File

@ -1,5 +1,5 @@
GMRAVFY ;HIRMFO/WAA,PWC-VERIFY AND SIGN OFF AN AGENT ; 5/23/07 10:32am
;;4.0;Adverse Reaction Tracking;**2,33**;Mar 29, 1996;Build 5
GMRAVFY ;HIRMFO/WAA-VERIFY AND SIGN OFF AN AGENT ;12/1/95 16:06
;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996
EN1 ;This is the main entry point for the verifier option.
S GMRAVER=0,GMRADRUG=0
I $P(GMRAPA(0),U,20)'["D" S GMRAFLAG=0 G VERIFY
@ -26,8 +26,7 @@ VERIFY ;Verify an agent
.Q
S GMRAPA(0)=$G(^GMR(120.8,GMRAPA,0)),GMRATYPE=$P(GMRAPA(0),U,20)
S DA=GMRAPA,DIE="^GMR(120.8,",DR="19////1;20///N;21////"_DUZ D ^DIE D:'GMRAVER EN1^GMRAVAB S GMRAPA(0)=$S($D(^GMR(120.8,GMRAPA,0)):^(0),1:"")
I $G(GMRANEW) D ;send NOTIFICATION bulletin if this is new -- GMRA*4*33
. I $P(GMRAPA(0),U,6)="o",GMRATYPE["D" D PTBUL^GMRAROBS
I $P(GMRAPA(0),U,6)="o",GMRATYPE["D" D PTBUL^GMRAROBS
I GMRAVER D EN1^GMRAPET0($P(GMRAPA(0),U),GMRAPA,"V",.GMRAOUT) I GMRAOUT S GMRAOUT=0
Q1 D UNLOCK^GMRAUTL(120.8,GMRAPA)
EXIT K GMRAFLAG,DA,DIE,DR,GMRADRUG Q

8
r/ASISTS-OOPS/OOPSGUIR.m
View File

@ -1,5 +1,5 @@
OOPSGUIR ;WIOFO/LLH-RPC routine for misc reports ;03/16/04
;;2.0;ASISTS;**8,7,11,14**;Jun 03, 2002;Build 1
;;2.0;ASISTS;**8,7,11**;Jun 03, 2002
;
ENT(RESULTS,INPUT,CALL) ; get the data for the report
; Input: INPUT - contains 3 values, the START AND END DATE,
@ -162,9 +162,9 @@ FLD95 ; use OUTC subrecord to retrieve data
..I $G(ED)=""!($G(ED)>EDATE) S DAYS=$$FMDIFF^XLFDT(EDATE,SD,1)+1
.I TAG="LOG300",($G(ED)="") S DAYS=$$FMDIFF^XLFDT(TDAY,SD,1)+1
.I '$G(DAYS) S DAYS=$S(OC="A":$P(S95,U,4),OC="J":$P(S95,U,5),1:0)
.I DAYA+DAYJ>179 Q
.I DAYA+DAYJ>180 Q
.S AVAIL=0
.I DAYS>179 S AVAIL=(180-(DAYA+DAYJ))
.I DAYS>180 S AVAIL=180
.I (DAYS<180) D
..I (DAYS+DAYA+DAYJ)<180 S AVAIL=DAYS
..I (DAYS+DAYA+DAYJ)>180 S AVAIL=(180-(DAYA+DAYJ))
@ -203,7 +203,7 @@ EMPHRS ; get Total Num Employees and Hours worked
S X1=$E(ED,1,3),X2=$E(SD,1,3)
I X1>X2 D
.S OK=0,X=(X1-X2) S:X>1 OK=(X-1)*12
.S OK=OK+((12-$E(SD,4,5))+1)+$E(ED,4,5)
.S OK=OK+(($E(ED,4,5)-$E(SD,4,5))+1)+$E(SD,4,5)
I X1=X2 S OK=($E(ED,4,5)-$E(SD,4,5))+1
S MON=OK
F S WS=$O(^OOPS(2262,LV1,LV2,SIEN,2,WS)) Q:(WS'>0) D

67
r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m
View File

@ -1,5 +1,5 @@
LA7ADL ;DALOI/JMC - Automatic Download of Test Orders;May 30, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57,66**;Sep 27, 1994;Build 30
LA7ADL ;DALOI/JMC - Automatic Download of Test Orders; 1/30/95 09:00
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57**;Sep 27, 1994
;
; This routine will monitor the ^LA("ADL") node to check for accessions which are to have test orders automatically
; downloaded to another computer system. All entries in the auto instrument file which are flagged for automatic downloading
@ -31,8 +31,15 @@ EN(LA7UID) ; Set flag to check accession for downloading, start background job i
; Quit if "Don't Start" flag set.
I +$G(^LA("ADL","STOP"),0)=2 Q
;
; Lock zeroth node.
; Quit if another process has lock
; - either another job setting node or the background job.
L +^LA("ADL",0):1
I '$T Q
;
; Task background job to run.
D CHKTSK
N ZTSK
D ZTSK
;
; Unlock node.
L -^LA("ADL",0)
@ -41,11 +48,14 @@ EN(LA7UID) ; Set flag to check accession for downloading, start background job i
;
;
DQ ; Entry point from Taskman.
;
; Set flag for taskman to cleanup task.
I $D(ZTQUEUED) S ZTREQ="@"
;
; Wait for a little while in case another job checking for background job has lock.
L +^LA("ADL",0):10
; Another process has lock, only want one at a time.
I '$T S:$D(ZTQUEUED) ZTREQ="@" Q
I '$T Q
;
; No instrument flagged for auto downloading.
I '$D(^LAB(62.4,"AE")) D EXIT Q
@ -53,9 +63,7 @@ DQ ; Entry point from Taskman.
; Quit if "Don't Start/Collect" flags set.
I +$G(^LA("ADL","STOP"),0)>1 Q
;
; Update XTMP entry to let auto download know we're running for this process
; and build table of tests to check for downloading}
D XTMP,BUILD
D BUILD
;
F D UID Q:TOUT>60
D EXIT
@ -71,9 +79,9 @@ UID ; Start loop to monitor for accessions to download.
;
F S LA7UID=$O(^LA("ADL","Q",LA7UID)) Q:LA7UID=""!(ZTSTOP)!(TOUT) D
. I +$G(^LA("ADL","STOP"))>0 S TOUT=61 Q
. I $$S^%ZTLOAD("Processing Lab UID "_LA7UID) S ZTSTOP=1,TOUT=61 Q
. I $$S^%ZTLOAD S ZTSTOP=1,TOUT=61 Q
. ; Lock this UID, synch setting/deleting when another job is attempting to set node.
. D LOCK^DILF("^LA(""ADL"",""Q"",LA7UID)")
. L +^LA("ADL","Q",LA7UID):1
. ; Unable to get lock, go on to next UID, check again on next go around.
. I '$T Q
. ; Get accession info from ^LRO(68,"C").
@ -92,13 +100,13 @@ UID ; Start loop to monitor for accessions to download.
. . N LA7UID
. . ; File build (entry^routine) from fields #93 and #94 in file #62.4.
. . D @$P(LA7AUTO(LA7INST,9),"^",3,4)
. D CLEANUP,XTMP
. D CLEANUP
;
F D Q:$O(^LA("ADL","Q",""))'="" Q:TOUT>60
. I $G(^LA("ADL","STOP"))>1 S TOUT=61 Q
. ; Task has been requested to stop.
. I $$S^%ZTLOAD("Idle - waiting for new accessions to process") S TOUT=61,ZTSTOP=1 Q
. S TOUT=TOUT+1 H 5 D XTMP
. I $$S^%ZTLOAD S TOUT=61,ZTSTOP=1 Q
. S TOUT=TOUT+1 H 5
;
Q
;
@ -188,27 +196,11 @@ CLEANUP ; Delete flag after accession has been checked.
Q
;
;
CHKTSK ; Check if we shoud task the auto download processing routine.
; Check if we recently tasked the processing routine for this process by compaing values in the XTMP global.
; Done to avoid repetitive locking attempts on each new accessione since the FileMan locking API uses a site-defined timeout which is usually 3 seconds
; but can be more. Slows down the interface if on each accession we are waiting 3 or more seconds for the lock to find out if the processing routine
; is already running.
;
N LA7X,LA7Y
S LA7X=$H,LA7Y=$G(^XTMP("LA7ADL",1))
I $P(LA7X,",")=$P(LA7Y,","),($P(LA7X,",",2)-$P(LA7Y,",",2))<240 Q
;
; Lock zeroth node.
; Quit if another process has lock - either another job setting node or the background job.
D LOCK^DILF("^LA(""ADL"",0)")
I '$T Q
;
ZTSK ; Task background job to run.
;
; Call here to queue this processing routine to run in the background.
N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
;
; Task background job if not running.
N ZTDESC,ZTSAVE,ZTDTH,ZTIO,ZTRTN
S ZTRTN="DQ^LA7ADL",ZTDESC="Lab Auto Download",ZTIO="",ZTDTH=$H
D ^%ZTLOAD
;
@ -216,7 +208,6 @@ ZTSK ; Task background job to run.
;
;
BUILD ; Build TMP global with list of tests for instruments flagged for auto download.
;
D BUILD^LA7ADL1
;
; Set flag to "Running".
@ -225,25 +216,17 @@ BUILD ; Build TMP global with list of tests for instruments flagged for auto dow
Q
;
;
XTMP ; Set/update XTMP with current run time of this processing routine
;
S DT=$$DT^XLFDT
S ^XTMP("LA7ADL",0)=DT_"^"_DT_"^LAB AUTO DOWNLOAD PROCESS TASKING"
S ^XTMP("LA7ADL",1)=$H
Q
;
;
EXIT ; Exit and cleanup.
;
; Release lock on LA("ADL") global.
L -^LA("ADL",0)
;
K ^TMP("LA7",$J),^TMP($J),^XTMP("LA7ADL",1)
K LA7ADL,LA7AUTO,LA7NVAF,LRAA,LRAD,LRAN,TOUT
K ^TMP("LA7",$J),^TMP($J)
K LA7ADL
K LRAA,LRAD,LRAN
K TOUT
;
; Clear flag if normal shutdown, no new accessions.
I +$G(^LA("ADL","STOP"))<2 K ^LA("ADL","STOP")
;
; Set flag for taskman to cleanup task.
I $D(ZTQUEUED) S ZTREQ="@"
Q

45
r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m
View File

@ -1,49 +1,48 @@
LA7UID ;DALIO/JRR - BUILD HL7 DOWNLOAD TO UI ;May 20, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57,66**;Sep 27, 1994;Build 30
;
LA7UID ;DALOI/JMC - BUILD HL7 DOWNLOAD TO UI; 12/3/1997
;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57**;Sep 27, 1994
Q
;
EN ; This line tag is called from ^LADOWN when downloading
; a load work list to the Auto Instrument. LADOWN1 should
; have already built ^TMP($J with all of the atomic and
; cosmic tests, ^TMP("LA7",$J holds all of the Instrument defined
; tests from 62.4.
EN ;; This line tag is called from ^LADOWN when downloading
; a load work list to the Auto Instrument.
;
; LRLL= IEN in 68.2 Load Worklist file, from field in 62.4
; LRINST= IEN IN 62.4 Auto Inst file
; LRAUTO= zero node of 62.4 entry
;
N LA7MODE
S LA7INST=LRINST
I '$G(LA7ADL) D BLDINST^LA7ADL1(LA7INST,LRLL)
S LA76248=$P($G(^LAB(62.4,+$G(LRINST),0)),"^",8)
S LA76248=$P(^LAB(62.4,LA7INST,0),"^",8)
I 'LA76248 D Q
. S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^")
. D ERROR,EXIT
. I '$D(ZTQUEUED) D ;
. I '$D(ZTQUEUED) D
. . W $C(7),!!,"You must have a MESSAGE CONFIGURATION defined in field 8 of"
. . W !,"the AUTO INSTRUMENT file before downloading to this instrument!"
. ;
. S XQAMSG="MESSAGE CONFIGURATION not defined in AUTO INSTRUMENT file for "_$P(LRAUTO,"^")
. D ERROR
. D EXIT
;
I '$P(^LAHM(62.48,LA76248,0),"^",3) D Q
. S XQAMSG="STATUS field in the LA7 MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^")
. D ERROR,EXIT
. I '$D(ZTQUEUED) D ;
. . W $C(7),!!,"The STATUS field in the LA7 MESSAGE PARAMETER file must be "
. I '$D(ZTQUEUED) D
. . W $C(7),!!,"The STATUS field in the MESSAGE PARAMETER file must be "
. . W !,"turned on before downloading to this instrument!"
. ;
. S XQAMSG="STATUS field in the MESSAGE PARAMETER file not turned on for "_$P(LRAUTO,"^")
. D ERROR
. D EXIT
;
S LA7MODE=$P(^LAHM(62.48,LA76248,0),"^",4)
;
; Call the routine specified in the PROCESS DOWNLOAD field in file 62.48
; Download for one whole load list is done
;
CALL ; Call the routine specified in the PROCESS DOWNLOAD field
; in file 62.48
X $G(^LAHM(62.48,LA76248,2))
;
EXIT I '$G(LA7ADL) K ^TMP("LA7",$J),LA76248
;
EXIT ; Download for one whole load list is done
I '$G(LA7ADL) K ^TMP("LA7-INST",$J),LA76248,LA7MODE
Q
;
;
ERROR ; Send warning of error in Auto Instrument file configuration.
;
S XQA("G.LAB MESSAGING")=""
D SETUP^XQALERT
K XQA,XQAMSG
Q

12
r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m
View File

@ -1,5 +1,5 @@
LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; 7/27/07 11:24am
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66**;Sep 27, 1994;Build 30
LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67**;Sep 27, 1994
;This routine is a continuation of LA7VIN1 and is only called from there.
Q
;
@ -88,10 +88,10 @@ OBR ; Process OBR segments
. S X=$P($G(^LRO(68,LA7AA,0)),U,3)
. S LA7AD=$S(X="D":DT,X="M":$E(DT,1,5)_"00",X="Y":$E(DT,1,3)_"0000",X="Q":$E(DT,1,3)_"0000"+(($E(DT,4,5)-1)\3*300+100),1:DT)
. S LA7AN=+LA7SID
. I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN) Q
. D SETID^LA7VHLU1(LA76249,LA7ID,$S($G(LA7PNM)]"":LA7PNM,$G(LA7SSN)]"":LA7SSN,1:"NO ID"))
. I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN)
. E D SETID^LA7VHLU1(LA76249,LA7ID,$S(LA7PNM]"":LA7PNM,LA7SSN]"":LA7SSN,1:"NO ID"))
;
; Zeroth node of accession area.
; Zeroth node of acession area.
S LA7AA(0)=$G(^LRO(68,+LA7AA,0))
; Accession's subscript
S LA7SS=$P(LA7AA(0),"^",2)
@ -119,8 +119,6 @@ OBR ; Process OBR segments
;
; Log error when specimen source does not match accession's specimen
I LA70070'="",LA7SPEC'="",LA70070'=LA7SPEC D
. ; Ignore if specimen related to lab control file #62.3
. I $P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0)),"^",2)=62.3 Q
. N LA7OBR
. S LA7OBR(15)=LA7SPEC ; backward compatible with old code
. S LA7ERR=22,LA7QUIT=2

15
r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m
View File

@ -1,5 +1,5 @@
LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ;May 29, 2008
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72,66**;Sep 27, 1994;Build 30
LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72**;Sep 27, 1994
; This routine is a continuation of LA7VIN5.
; It is performs processing of fields in OBX segments.
Q
@ -10,7 +10,7 @@ XFORM ; Transform the result based on fields 12,13,14,16,17 in the Chem Test
N LA7I
S LA7XFORM=LA76241(2)
;
; get PARAM 1 overrides
; get PARAM 1 overides
I $D(LA7XFORM(1)),LA7XFORM(1)?1.N S $P(LA7XFORM,"^")=LA7XFORM(1)
F LA7I=2,3,5,6 I $D(LA7XFORM(LA7I)) S $P(LA7XFORM,"^",LA7I)=LA7XFORM(LA7I)
; set up defaults if field was not answered
@ -55,7 +55,7 @@ CHKDIE ; Check if value to be stored passes input transform of field in DD
N LA7ERR,LA7Y
;
; If result is on a LEDI interface (type=10) then don't check result
; against FileMan input transform.
; against FileMan input tranform.
; VistA sends "canc" as test result when test is cancelled.
; DoD sends "PL Canceled" --> change to "canc" for VistA storage.
I LA7INTYP=10 D Q
@ -113,17 +113,12 @@ PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
; LA7SFAC = sending facility
; LA7CS = component encoding character
;
; Remove units/reference ranges when Lab UI interface
; so file #60 settings always used
I $G(LA7INTYP)=1 S $P(^LAH(LA7LWL,1,LA7ISQN,LA76304),"^",5)="" Q
;
N LA74,LA7I,LA7X,LA7Y
;
S LA7X=$P(LA7PRDID,LA7CS,2),LA74=""
;
F LA7I=1,4 D Q:LA74
. I $P(LA7PRDID,LA7CS,LA7I+2)="99VA4" S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I))
. I 'LA74,$P(LA7PRDID,LA7CS,LA7I+2)?1(1"L-CL",1"CLIA",1"99VACLIA") S LA74=$$IDX^XUAF4("CLIA",$P(LA7PRDID,LA7CS,LA7I))
. I 'LA74 S LA74=$$LKUP^XUAF4($P(LA7PRDID,LA7CS,LA7I+1))
. I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7PRDID,LA7CS),1,1)
. I 'LA74 S LA74=$$FINDSITE^LA7VHLU2($P(LA7SFAC,LA7CS),1,1)
@ -146,7 +141,6 @@ PRDID(LA7PRDID,LA7SFAC,LA7CS) ; Process/Store Producer's ID
REFRNG(LA7X) ; Process/Store References Range.
; Call with LA7X = reference range to store.
;
Q:$G(LA7INTYP)=1
N LA7Y,X,Y
;
; Check if site does not want to store reference ranges on POC test.
@ -190,7 +184,6 @@ ABFLAG(LA7X) ; Process/Store Abnormal Flags.
; Converts flag to interpretation based on HL7 Table 0078.
; If no match store code instead of interpretation
;
Q:LA7INTYP=1
N I,LA7I,LA7Y,X
;
; Store abnormal flags in LAH global with results.

13
r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m
View File

@ -1,18 +1,11 @@
DVBCREQ1 ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91 11:36 AM
;;2.7;AMIE;**19,29,126**;Apr 10, 1995;Build 8
;;2.7;AMIE;**19,29**;Apr 10, 1995
;
START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0
D HDR
D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO
W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
W ?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,! ;I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT ;DVBA/126 comment off this code
I $D(^DPT(DFN,.121)) I $D(DTT) D ;DVBA/126
.Q:$P(DTT,U,9)=""!($P(DTT,U,9)="N")
.I $P(DTT,U,7)'="" Q:$P(DTT,U,7)>DT
.I $P(DTT,U,8)'="" Q:$P(DTT,U,8)<DT
.W !?2,"Temporary Address: ",TAD1,! W:TAD2]"" ?21,TAD2,! W:TAD3]"" ?21,TAD3,!
.W ?2,"City,State,Zip+4: ",?48,"Temporary Phone: ",!?5,TCITY," ",TST," ",TZIP,?51,TPHONE,!
I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT ;DVBA/126
W !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,!
F LINE=1:1:80 W "="
S TVAR(1,0)="0,0,0,2:1,0^** Priority of exam: "_PRIO
@ -36,7 +29,7 @@ START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME
F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT)) S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK
D:('$D(GETOUT)) ^DIWW
; ** Exit TAG **
EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE Q
EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO Q
;
HDR S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF
W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4

11
r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m
View File

@ -1,11 +1,11 @@
DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91 11:16 AM
;;2.7;AMIE;**17,126**;Apr 10, 1995;Build 8
;;2.7;AMIE;**17**;Apr 10, 1995
KILL ;common exit
D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB
K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT
K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
K DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE
K DTTRNSC,ZIP4,DVBAINSF
G KILL^DVBCUTL2
;
DICW ;used on ^DIC lookups only
@ -27,13 +27,6 @@ VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=
I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip"
S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown")
S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
I $D(^DPT(DFN,.121)) D ;DVBA/126 added
.S (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)=""
.S DTT=^DPT(DFN,.121)
.S TAD1=$P(DTT,U,1),TAD2=$P(DTT,U,2),TAD3=$P(DTT,U,3),TCITY=$P(DTT,U,4)
.S TZIP=$P(DTT,U,12) S:TZIP'="" TZIP=$S($L(TZIP)>5:$E(TZIP,1,5)_"-"_$E(TZIP,6,9),1:TZIP) I TZIP="" S TZIP="No Zip"
.S TCITY=$S(TCITY]"":TCITY,1:"Unknown") S TST=$P(DTT,U,5) I TST]"" S TST=$S($D(^DIC(5,TST,0)):$P(^(0),U,1),1:"Unknown")
.S TPHONE=$P(DTT,U,10) S:TPHONE="" TPHONE="Unknown"
S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y
Q
;

7
r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m
View File

@ -1,6 +1,5 @@
ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified.
ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003 07:59
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
Q
;
PARSIT ;PARSE MESSAGE ON RECEIVING SIDE
@ -44,7 +43,7 @@ FILE ;Store File 200 data on backup system
;S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
;If SSN lookup fails, try name lookup and add
I +Y<1 S DLAYGO=200,DIC="^VA(200,",DIC(0)="LM",X=ALPBNAM D ^DIC K DIC,DA,DR
I +Y>0 S (ALPBDA,DA,DUZ)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
I +Y>0 S (ALPBDA,DA)=+Y S ALPBMENU=$O(^DIC(19,"B","PSB BCBU WRKSTN MAIN",0)) D
. S DIE="^VA(200,",DR="2////^S X=ALPBAC"
. ;Update name too
. S DR=DR_";.01////^S X=ALPBNAM"

12
r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m
View File

@ -1,6 +1,5 @@
ALPBINP ;OIFO-DALLAS/SED/KC/MW BCMA - BCBU INPT TO HL7 ;5/2/2002
;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified.
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
;This routine will intercept the HL7 message that it sent from Pharmacy
;to CPRS to update order information. The message is then parsed and
;repackage so it can be sent to the BCBU workstation.
@ -45,7 +44,6 @@ IPH(MSG) ;CAPTURE MESSAGE ARRAY FROM PHARMACY
K ALPB
D EN^PSJBCBU(ALPDFN,ALPORD,.ALPB)
SEED ;Entry point for ^ALPBIND
N VAIN
D INIT
S SUB=0 F S SUB=$O(ALPB(SUB)) Q:'SUB D
. ;convert and move the message to the HLA array for transport
@ -66,7 +64,7 @@ SEED ;Entry point for ^ALPBIND
D RXE
;Get the Division that the patient is associated with
D PDIV
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
I '$D(HLL("LINKS")) Q "0^HL7^Missing HLL Links Array Division # "_ALPDIV
;SET NEW PV1
D NOW^%DTC
@ -143,7 +141,7 @@ PDIV ;PATIENT DIVISION
S:+$G(ALPBMDT)'>0 ALPBMDT=0
S ALPDIV=$$DIV^ALPBUTL1(ALPDFN,ALPBMDT)
;Screen Dom
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q
Q:ALPDIV="DOM"
;Now do I send the Message or not Based of Division
I $D(ALPHLL("LINKS")) M HLL("LINKS")=ALPHLL("LINKS")
I '$D(HLL("LINKS")) D GET^ALPBPARM(.HLL,ALPDIV)
@ -160,7 +158,7 @@ MEDL(ALPML) ;Use this entry to send MedLog messages
I +ALPDFN'>0 Q "0^"_ALPML_"^Invalid or Missing Patient - Med-Log"
;Get the Division that the patient is associated with
D PDIV
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
I '$D(HLL("LINKS")) Q "0^"_ALPML_"^Missing HLL Links Array Med-Log"
S ALPST=$P($G(^PSB(53.79,ALPML,0)),U,9)
S ALPBY=$P($G(^PSB(53.79,ALPML,0)),U,7)
@ -201,7 +199,7 @@ PMOV(ALPDFN,ALPTYP,ALPTT,ALPBMDT) ;Entry Point to send patient movement
S:$G(ALPTT)'="DISCHARGE" ALPBMDT=0
;Get the Division that the patient is associated with
D PDIV
I ALPDIV="DOM",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "0^^Screen of DOMICILIARY"
I ALPDIV="DOM" Q "0^^Screen of DOMICILIARY"
I '$D(HLL("LINKS")) Q "0^"_ALPDFN_"^Missing HLL Links Array Pat-Move"
S HLA("HLS",1)=$$EN^VAFHLPID(ALPDFN,"2,7,8,19")
S HLA("HLS",2)=$$EN^VAFHAPV1(ALPDFN,DT,"2,3,7,18")

6
r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m
View File

@ -1,6 +1,5 @@
ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified.
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
;
; NOTE: this routine is designed for hard-copy output.
; Output is formatted for 132-column printing.
@ -143,9 +142,8 @@ DQ ; output entry point...
;SORT BY ROOM/BED
I ALPBSORT="R" D
.S ALPBD="",ALPRM=""
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D Q:ALPBPTN=""
.F S ALPBPTN=$O(^TMP($J,ALPBPTN)) Q:ALPBPTN="" D
..I ALPBPTN="BCBU" S ALPBPTN=$O(^TMP($J,ALPBPTN)) ;SKIP "BCBU" SUBSCRIBE
..I ALPBPTN="" Q ;PSB*3*37 Stop null subscript when "BCBU" is the last entry in ^TMP
..S ALPBIEN=^TMP($J,ALPBPTN) S ALPRM=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",6),ALPBD=$P($G(^ALPB(53.7,ALPBIEN,0)),"^",7)
..I ALPBD="" S ALPB="NONE" I ALPRM="" S ALPB="NONE" ;INCASE NO ROOM AND BED YET
..S ^TMP($J,"BCBU",ALPRM,ALPRM,ALPBD,ALPBPTN)=ALPBIEN

5
r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m
View File

@ -1,6 +1,5 @@
ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES ;01/01/03
;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
;;Per VHA Directive 2004-038, this routine should not be modified.
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
;
; Reference/IA
; INP^VADPT/10061
@ -180,7 +179,7 @@ DIV(DFN,ALPBMDT) ;get the Division for a patient
S ALPWRD=$P($G(VAIN(4)),U,1)
Q:+ALPWRD'>0 ""
;Check to see if ward is a DOMICILIARY
I $P($G(^DIC(42,ALPWRD,0)),U,3)="D",+$$GET^XPAR("PKG.BAR CODE MED ADMIN","PSB BKUP DOM FILTER",1,"Q")>0 Q "DOM"
I $P($G(^DIC(42,ALPWRD,0)),U,3)="D" Q "DOM"
S ALPBDIV=$P($G(^DIC(42,ALPWRD,0)),U,11)
Q:+ALPBDIV'>0 ""
Q ALPBDIV

4
r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m
View File

@ -1,5 +1,5 @@
PSBO ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**13,32,2**;Mar 2004;Build 22
;;3.0;BAR CODE MED ADMIN;**13,32**;Mar 2004;Build 32
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
; Reference/IA
; ^DPT(/10035
@ -70,7 +70,7 @@ XQ(PSBTYPE) ; Called via Kernel Menus
I 'PSBSAVE W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!"
D:PSBSAVE
.;Check Drug to Patient Relationship.
.I (PSBTYPE="BL")!(PSBTYPE="BZ") S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
.I PSBTYPE="BL" S PSBANS="" D CHECK I PSBANS=0!($D(DIRUT)) W !,"Cancelling Request..." S DIK="^PSB(53.69," D ^DIK W "Cancelled!" Q
.;
.;Allow "'BROWSER" Device
.S IOP=$$GET1^DIQ(53.69,DA_",",.06,"I"),PSBSIO=0 I IOP]"" D

6
r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m
View File

@ -1,5 +1,5 @@
PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**4,13,32,2,43**;Mar 2004;Build 2
;;3.0;BAR CODE MED ADMIN;**4,13,32**;Mar 2004;Build 32
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
; Reference/IA
; FILE^DICN/10009
@ -8,11 +8,11 @@ NEW(RESULTS,PSBRTYP) ; Create a new report request
; Called interactively and via RPCBroker
K RESULTS
; Check Type
I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^BZ^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
I '$F("DL^MD^MH^ML^MM^MV^MT^PE^PM^WA^BL^PI^AL^DO^VT^PF^XA^IV^CM^CP^CE^CI^",PSBRTYP) S RESULTS(0)="-1^Invalid Report Type" Q
I '+$G(DUZ) S RESULTS(0)="-1^Undefined User" Q
I '$G(DUZ(2)) S RESULTS(0)="-1^Undefined Division" Q
; Lock Log
L +(^PSB(53.69,0)):$S($G(DILOCKTM)>30:DILOCKTM,1:30)
L +(^PSB(53.69,0)):0
E S RESULTS(0)="-1^Request Log Locked" Q
; Generate Unique Entry and Create
F D NOW^%DTC S X=$E(%_"000000",1,14) S X=(1700+$E(X,1,3))_$E(X,4,14),X=PSBRTYP_"-"_$TR(X,".","-") Q:'$D(^PSB(53.69,"B",X))

2
r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m
View File

@ -1,5 +1,5 @@
PSBOMH1 ;BIRMINGHAM/EFC-MAH ;7:40 PM 30 Jan 2008
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08;Build 4
;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38,VWEHR1**;WorldVistA 30-Jan-08
;Per VHA Directive 2004-038, this routine should not be modified.
;
;Modified from FOIA VISTA,

14
r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m
View File

@ -1,12 +1,12 @@
PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;;3.0;BAR CODE MED ADMIN;;Mar 2004
;
; Reference/IA
; ^DIC(42/1377
; ^DIC(42/2440
; EN^PSJCBMA1/2829
; EN^PSJBCMA2/2830
; VADPT/10061
;
; DIQ(2/10035
;
EN(PSBDFN,PSBORD) ;
;
@ -15,15 +15,15 @@ EN(PSBDFN,PSBORD) ;
D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
; get IV parameters for the current ward
S PSBCSTR="^ADDITIVE^STRENGTH^BOTTLE^SOLUTION^VOLUME^INFUSION RATE^MED ROUTE^SCHEDULE^ADMIN TIME^REMARKS^OTHER PRINT INFO^PROVIDER^START DATE/TIME^STOP DATE/TIME^PROVIDER COMMENTS"
D INP^VADPT S PSBWARD=$P(VAIN(4),"^"),PSBWDIV=PSBWARD D KVAR^VADPT
S PSBWARD=$$GET1^DIQ(2,PSBDFN_",",.1),PSBWARD=$$FIND1^DIC(42,"","X",PSBWARD),PSBWDIV=PSBWARD
I $G(PSBWARD)'="",$D(^PSB(53.66,"B",PSBWARD)) D ; if IV paramaters defined for ward use them
.S PSBWARD=$O(^PSB(53.66,"B",PSBWARD,""))
.S:$D(^PSB(53.66,PSBWARD,1,"B",PSBIVT)) PSBIVPAR=^PSB(53.66,PSBWARD,1,$O(^PSB(53.66,PSBWARD,1,"B",PSBIVT,""),-1),0)
I '$D(PSBIVPAR) S PSBIVPAR=PSBIVT D ; if IV parameters not defined for ward get defaults for division
.D:$D(PSBWDIV) ; Get the appropriate DIV for ward and DIVISIONAL IV PARAMETERS
..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I")
..S PSBWDIV=$$GET1^DIQ(42,PSBWDIV_",",.015,"I"),PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1)
..I $G(PSBWDIV)']"" S PSBWDIV="DIV"
..E S PSBWDIV=$P($$SITE^VASITE(DT,PSBWDIV),U,1),PSBWDIV="DIV.`"_PSBWDIV
..E S PSBWDIV="DIV.`"_PSBWDIV
..F X=2:1 Q:$P(PSBCSTR,U,X)="" S PSBIVPAR=PSBIVPAR_U_$P($P($$GET^XPAR(PSBWDIV,"PSBIV "_$P(PSBCSTR,U,X),PSBIVT,"B"),U,2),"-",1)
..K PSBWDIV ; Kill temp variable.
F PSBC1=1:1 Q:$P(PSBONXS,U,PSBC1)="" D ; process all orders

2
r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m
View File

@ -1,5 +1,5 @@
PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;7:42 PM 30 Jan 2008
;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08;Build 4
;;3.0;BAR CODE MED ADMIN;**6,3,16,32,WVEHR1**;WorldVistA 30-Jan-08
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
;Modified from FOIA VISTA,

4
r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m
View File

@ -1,5 +1,5 @@
DGBTCE ;ALB/SCK - BENEFICIARY TRAVEL CLAIM RE-ENTER/EDIT; 12/15/92 06/04/93
;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7
;;1.0;Beneficiary Travel;**2**;September 25, 2001
Q
SCREEN ;
D QUIT^DGBTCE1
@ -21,7 +21,7 @@ SCREEN ;
. S DIE="^DGBT(392,",DA=DGBTDT
. D ^DIE K DIE,DQ,DR I $D(DTOUT)!($D(Y)) S DGBTTOUT=1
DIE1 ;
S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):$J((DGBTOWRT*DGBTML*DGBTMR),0,2),1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT
S DGBTMLT=$S($D(DGBTVAR("M"))&((DGBTACCT=4)!(DGBTACCT=5)):DGBTOWRT*DGBTML*DGBTMR,1:""),$P(^DGBT(392,DGBTDT,"M"),"^",3)=DGBTMLT,$P(DGBTVAR("M"),"^",3)=DGBTMLT
;
S DIE="^DGBT(392,",DA=DGBTDT
I 'DGBTCORE D

5
r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m
View File

@ -1,5 +1,5 @@
DGBTCR ;ALB/SCK - BENEFICIARY TRAVEL FORM 70-3542d VARIABLES; 2/7/88@08:00 ;6/11/93@09:30
;;1.0;Beneficiary Travel;**7,14**;September 25, 2001;Build 7
;;1.0;Beneficiary Travel;**7**;September 25, 2001
;Modification of AIVBTPRT / pmg / GRAND ISLAND ; 07 Jul 88 12:02 PM
START Q:'$D(DGBTDT)
S DGBTVAR(0)=$G(^DGBT(392,+DGBTDT,0)),DGBTACCT=$P($G(^DGBT(392.3,+$P(DGBTVAR(0),"^",6),0)),"^",5)
@ -36,8 +36,7 @@ MILES S DGBTM6=$P(DGBTVAR("M"),"^")*$P(DGBTVAR("M"),"^",2)
S X=$P(DGBTVAR("M"),"^",4) D COMMA^%DTC S DGBTM9=X
S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X
S X=DGBTM6*DGBTM7+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X
S X2="3$",X=DGBTM7 D COMMA^%DTC S DGBTM7=X
S X2="2$" ;Reset edit mask to 2 decimal positions for rest of report
S X=DGBTM7 D COMMA^%DTC S DGBTM7=X
S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X
S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X
S X=$P(DGBTVAR(0),"^",10) D COMMA^%DTC S DGBTM14=X

4
r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m
View File

@ -1,5 +1,5 @@
DGBTEE ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT; 12/3/92@1600
;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7
;;1.0;Beneficiary Travel;**2**;September 25, 2001
Q
SCREEN ;
D SCREEN^DGBTEE1 Q:DGBTTOUT=-1!(DGBTTOUT=1) Q:'$D(^DGBT(392,DGBTDT,0))
@ -25,7 +25,7 @@ DIE1 ; stuff from,to address, meals, ferry's/bridges
. I DGBTRMK]"" W !,*7,"MILEAGE REMARKS: ",DGBTRMK,!
EDIT ; display trip type, mileage
I DGBTACCT=4!(DGBTACCT=5) S DR="32//"_DGBTML_";S DGBTML=X;31//"_DGBTOWRT_";S DGBTOWRT=X;" D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DGBTMLT=$J(DGBTMLT,0,2),DR="33///"_DGBTMLT
S:DGBTACCT=5&(DGBTCP=1) DGBTMR=DGBTMR1 S DGBTMLT=DGBTOWRT*DGBTML*DGBTMR,DR="33///"_DGBTMLT
D ^DIE I X=""!(X="^") S DGBTTOUT=-1 Q
DIE2 ; stuff eligibility data, SC%, acct. type
S DIE("NO^")="12345" S:'$D(DGBTCD) DGBTCD=""

4
r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m
View File

@ -1,5 +1,5 @@
DGBTEE1 ;ALB/SCK - BENEFICIARY TRAVEL ENTER/EDIT CHECK; 12/7/92 3/19/93
;;1.0;Beneficiary Travel;**14**;September 25, 2001;Build 7
;;1.0;Beneficiary Travel;;September 25, 2001
Q
SCREEN ; called by dgbtee,dgbtce
Q:'$D(^DGBT(392,DGBTDT,0))
@ -52,7 +52,7 @@ ACCT ; allowed to select only valid active accounts
I Y'>0 W !,"ACCOUNT IS REQUIRED!!" G ACCT
S DGBTACTN=$P(Y,"^"),DGBTACCT=$P(Y(0),"^",5)
; if account is ALL OTHER - stuff in mileage info
I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=$J((DGBTML*DGBTOWRT*DGBTMR),0,2)
I $D(DGBTVAR("M")) S DGBTML=$P(DGBTVAR("M"),"^",2),DGBTOWRT=$P(DGBTVAR("M"),"^"),DGBTMLT=DGBTML*DGBTOWRT*DGBTMR
QUIT ;
K A,C,I,IA,J,X,XX,^TMP("DGBT",$J),DGBTDIV,DGBTIDT,DGBTCT
Q

4
r/BENEFICIARY_TRAVEL-DGBT/DGBTEF1.m
View File

@ -1,12 +1,10 @@
DGBTEF1 ;ALB/SCK - BENEFICIARY TRAVEL UPDATE PARAMETERS INTO FILES ;12/14/92 3/12/93
;;1.0;Beneficiary Travel;**2,14**;September 25, 2001;Build 7
;;1.0;Beneficiary Travel;**2**;September 25, 2001
RATES ;enter/edit bene travel parameters;option DGBT BENE TRAVEL RATES
S DA=1,DR="720;723;721",DIE="^DG(43," D ^DIE G QUIT:X="^"!($D(DTOUT))!($D(Y)) K DA,DE,DQ,DR,DIE
Q ;This Q was added under direction of CBO to remove site's ability to edit rates
W !!,"New travel rates are determined each fiscal year. The rates should be",!,"entered each year with the effective date of Oct 1.",!
W !,"Changing values for the current or past fiscal years could result in changes",!,"to the claims already entered.",!
DATE ; change deductible rates for FY
Q ;This Q was added under direction of CBO to remove site's ability to edit rates
S DIR("A")="Select EFFECTIVE DATE",DIR(0)="DO^^E",DIR("?")="^D HELP1^DGBTEF1"
D ^DIR K DIR G QUIT:$D(DIRUT) G HELP:$E(Y,4,7)'="1001" S X=+Y
S DIC="^DG(43.1,",DIC(0)="ELQMZ"

16
r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m
View File

@ -1,8 +1,5 @@
RORHL09 ;HOIFO/BH - HL7 OUTPATIENT DATA: PV1,OBR,OBX ; 3/13/06 9:24am
;;1.5;CLINICAL CASE REGISTRIES;**1,5**;Feb 17, 2006;Build 10
;
; 11/29/2007 BAY/KAM ROR*1.5*5 Rem Call 218601 Correct Outpatient
; CPTs not transmitting to the AAC
;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
;
; This routine uses the following IAs:
;
@ -163,14 +160,11 @@ PROCS() ;
. Q:PROC<0
. ;---
. S PRV=+$P($G(^TMP("PXKENC",$J,RORIEN,"CPT",K5,12)),U,4)
. ;12/06/2007 BAY/KAM REM CALL 218601 Modified next 8 lines
. Q:PRV'>0
. ;---
. I PRV>0 D
.. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
.. I $G(DIERR) D S ERRCNT=ERRCNT+1
... D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
. E S PRV=""
. ;----------> End of changes for 218601
. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
. I $G(DIERR) D S ERRCNT=ERRCNT+1
. . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
. ;---
. D SETOBX(OID,PROC,PRV)
Q ERRCNT

116
r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m
View File

@ -1,5 +1,5 @@
RGEVPRG ;BAY/ALS-OPTIONS TO PURGE MPI/PD EXCEPTIONS ;08/23/99
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44,50,52**;30 Apr 99;Build 2
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44**;30 Apr 99;Build 8
;
MAIN ;
;Q:($D(^TMP("RGEXC")))!($D(^TMP("RGEXC2")))
@ -9,7 +9,7 @@ MAIN ;
I $D(ZTQUEUED) S ZTREQ="@"
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",1)=$$NOW^XLFDT
S $P(^RGSITE(991.8,1,"EXCPRG"),"^",3)="R"
;D PROC ;**52 Module is obsolete
D PROC
D PRGDUP
D PRG30
D PRGZZ
@ -90,7 +90,6 @@ PRG30 ; Purge Exceptions over 30 days old
K DIFF,TODAY,EXCDT,CNT,IEN,IEN2,NUM,STAT
Q
PRGEXC ; Purge by Exception Type
;**52 This module was obsolete before 52; just adding comment
;S DIC="^RGHL7(991.11,",DIC(0)="QEAM"
;S DIC("A")="Enter an exception type to purge: "
;D ^DIC K DIC G:Y<200 QUIT S EXCTYP=+Y,ETYPE=X
@ -107,41 +106,83 @@ PRGEXC ; Purge by Exception Type
;I CNT=0 W !,"There are no "_ETYPE_" exceptions on file."
;E I CNT>0 W !,CNT_" "_ETYPE_" Exceptions purged!"
;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
Q ;**52;if module accidentally called, should quit instead of falling into next module.
PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
;**50 through remainder of module.
;Q
PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234.
S EXCTYP="",CNT=0
K ^TMP("RGEVDUP",$J)
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
. I EXCTYP=234 Q ;**44 process 234s separately below
. S RGDFN=""
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
... S IEN2=0
... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
.... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q ;exception processed
.... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
.... S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
.... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D Q
..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
.... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D ;duplicate exists; compare incoming to previous.
.... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D
..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
..... I EXCDT>OLDDT D Q ;incoming date greater than previous? purge old, keep new.
..... S OLDDT=$P(OLDNODE,"^")
..... I EXCDT>OLDDT D Q
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
...... I NUM>1 D
....... S DA(1)=OLDIEN,DA=OLDIEN2
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA
...... E I NUM>1 D
....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3)
....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
...... S CNT=CNT+1
...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
..... ;
..... I OLDDT>EXCDT!(OLDDT=EXCDT) D ;previous date greater or equal incoming? purge new, keep old.
..... I OLDDT>EXCDT!(OLDDT=EXCDT) D
...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
...... I NUM>1 D DEL
...... ;
K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
...... E I NUM>1 D DEL
; W !,CNT_" Duplicate entries"
;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day.
;**44 through remainder of module.
K ^TMP("RGDFNDT",$J) S RGDFN=""
F S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN D
.S IEN=0
.F S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN D
..S IEN2=0
..F S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2 D
...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
...;How many for each DFN? Store in ^TMP("RGDFNDT")
...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0
...I $D(^TMP("RGDFNDT",$J,RGDFN)) D
....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1
....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time
;If RGDFN has more than 1 exception, see if any are for same DAY.
;Process the ^TMP("RGDFNDT",$J global to build LOC array.
I $D(^TMP("RGDFNDT",$J)) D
.S RGDFN=""
.F S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN D
..;If only one 234 exception for DFN ignore it.
..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q
..;More than one for this DFN? How many for same day?
..S IEN=0 K LOC
..F S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN D
...S (IEN2,VAL)=0
...F S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2 D
....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^")
....I '$D(LOC(VAL)) S LOC(VAL)=0
....I $D(LOC(VAL)) D
.....S LOC(VAL)=LOC(VAL)+1
.....S LOC(VAL,IEN,IEN2)=""
..;Process the LOC array; contains numbers / day / DFN.
..;If only 1 exception / day, keep it.
..S RGDT=0 K CTR,TOT
..F S RGDT=$O(LOC(RGDT)) Q:'RGDT D
...S TOT=LOC(RGDT)
...I TOT=1 K TOT Q ;only 1.
...;More than 1, delete all except 1.
...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day.
...S IEN=0,CTR=0
...F S IEN=$O(LOC(RGDT,IEN)) Q:'IEN D
....I CTR=TOT Q
....S CTR=CTR+1,IEN2=0
....F S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2 D DEL ;delete entry
K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT")
Q
;
PRGZZ ;Purge if name field is null (incomplete record)
;Purge if -9 node exists, this indicates the record has been merged.
S EXCTYP="",CNT=""
@ -166,23 +207,22 @@ DEL ;
D ^DIK K DIK,DA
Q
PROC ;Set these exception types to PROCESSED if they have a national ICN
;**52 The PROC module is obsolete and is no longer being called.
;209 - Required field(s) missing for patient sent to MPI,
;227 - Multiple ICNs, 213 - SSN Match Failed, 214 - Name Doesn't Match
;S EXCTYP=""
;S HOME=$$SITE^VASITE()
;F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
;.. S IEN=0
;.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
;... S IEN2=0,ICN="",RGDFN=""
;... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
;.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
;.... S ICN=+$$GETICN^MPIF001(RGDFN)
;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
;..... L +^RGHL7(991.1,IEN):10
;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
;..... D ^DIE K DIE,DA,DR
;..... L -^RGHL7(991.1,IEN)
;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
S EXCTYP=""
S HOME=$$SITE^VASITE()
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D ;**43
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
... S IEN2=0,ICN="",RGDFN=""
... F S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2 D
.... S RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
.... S ICN=+$$GETICN^MPIF001(RGDFN)
.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
..... L +^RGHL7(991.1,IEN):10
..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
..... D ^DIE K DIE,DA,DR
..... L -^RGHL7(991.1,IEN)
K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
Q

49
r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX01.m
View File

@ -1,5 +1,5 @@
RGEX01 ;BAY/ALS-LIST MANAGER FOR MPI/PD EXCEPTIONS ;10/07/99
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48,52**;30 Apr 99;Build 2
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,47,48**;30 Apr 99;Build 3
;
;Reference to MAIN^VAFCPDAT supported by IA #3299
EN ; -- main entry point for RG EXCPT SUMMARY
@ -101,7 +101,7 @@ CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
N EXCTYP,RG1,RG2,RGEX
S EXCTYP="",(RG1,RG2,RGEX)=0
F S EXCTYP=$O(^RGHL7(991.1,"ASTAT","0",EXCTYP)) Q:'EXCTYP D
.I (EXCTYP=234)!(EXCTYP=218) S RG1=1 ;MPIC_772; **52 remove 215, 216, and 217
.I ((EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219))) S RG1=1
.I (EXCTYP=234) S RG2=1 ;Primary View Reject
I (RG1=1),(RG2=1) S RGEX=3 ;Send both messages
I (RG1=1),(RG2=0) S RGEX=1 ;Only unresolved exceptions exist
@ -109,30 +109,29 @@ CUREX() ;Are there any patients in the CIRN HL7 EXCEPTION LOG file (#991.1)
Q RGEX
;
PROC ; For a given patient, set exceptions STATUS to PROCESSED.
;**52 The PROC module is obsolete and is no longer being called.
; DFN must be defined
;Q:'$D(DFN)
;S EXCTYP=""
;S HOME=$$SITE^VASITE()
;F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
;. S RGDFN="",ICN=""
;. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
;.. I DFN=RGDFN D
;... S ICN=+$$GETICN^MPIF001(DFN)
;... ;Only set to PROCESSED if patient has national ICN.
;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
;.... ;Exclude Death exceptions (215-217); they must be processed manually.
;.... ;Exclude 218 Potential Matches Returned exception **43
;.... I (EXCTYP>218)!(EXCTYP<215) D
;..... S IEN=0
;..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
;...... S IEN2=0
;...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
;....... L +^RGHL7(991.1,IEN):10
;....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
;....... D ^DIE K DIE,DA,DR
;....... L -^RGHL7(991.1,IEN)
;K IEN,IEN2,RGDFN,EXCTYP,ICN
Q:'$D(DFN)
S EXCTYP=""
S HOME=$$SITE^VASITE()
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
. S RGDFN="",ICN=""
. F S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN D
.. I DFN=RGDFN D
... S ICN=+$$GETICN^MPIF001(DFN)
... ;Only set to PROCESSED if patient has national ICN.
... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
.... ;Exclude Death exceptions (215-217); they must be processed manually.
.... ;Exclude 218 Potential Matches Returned exception **43
.... I (EXCTYP>218)!(EXCTYP<215) D
..... S IEN=0
..... F S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN D
...... S IEN2=0
...... F S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2 D
....... L +^RGHL7(991.1,IEN):10
....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
....... D ^DIE K DIE,DA,DR
....... L -^RGHL7(991.1,IEN)
K IEN,IEN2,RGDFN,EXCTYP,ICN
Q
PDAT ;
K DIRUT

10
r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m
View File

@ -1,5 +1,5 @@
RGEX06 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE MPI PRIMARY VIEW PDAT ;5/17/07
;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,53**;30 Apr 99;Build 2
;;1.0;CLINICAL INFO RESOURCE NETWORK;**48**;30 Apr 99;Build 3
;
;Reference to ^XWB2HL7 supported by IA #3144
;Reference to ^XWBDRPC supported by IA #3149
@ -17,9 +17,9 @@ INIT ;Display the MPI Primary View Patient Data (PDAT)
K @VALMAR
I '$D(ICN) G EXIT
S LIN=1,X=0,STR="",TXT=""
I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP
I '$D(^XTMP("RGPVMPI",ICN)) S TXT=" - No MPI Primary View data exists for this patient." D ADDTMP
N STATUS,R,RETURN,RESULT,RET
I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D
I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
..;Retrieve the data
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D
@ -50,9 +50,9 @@ EXPND ; -- expand code
Q
;
SAPV(ICN) ;Print stand alone Primary View display
I '$D(^XTMP("RGPVMPI"_ICN,"DATA")) W !," - No MPI Primary View data exists for this patient." Q
I '$D(^XTMP("RGPVMPI",ICN)) W !," - No MPI Primary View data exists for this patient." Q
N STATUS,R,RETURN,RESULT,RET
I $D(^XTMP("RGPVMPI"_ICN,"DATA")) S RETURN(0)=$P(^XTMP("RGPVMPI"_ICN,"DATA"),"^") D
I $D(^XTMP("RGPVMPI",ICN)) S RETURN(0)=$P(^XTMP("RGPVMPI",ICN),"^") D
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
..;Retrieve the data
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D

6
r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m
View File

@ -1,5 +1,5 @@
RGEX07 ;BIR/PTD-LIST MANAGER ROUTINE FOR REMOTE PRIMARY VIEW DISPLAY ;10/17/06
;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,53**;30 Apr 99;Build 2
;;1.0;CLINICAL INFO RESOURCE NETWORK;**44**;30 Apr 99;Build 8
;
;Reference to ^XWB2HL7 supported by IA #3144
;Reference to ^XWBDRPC supported by IA #3149
@ -18,9 +18,9 @@ INIT ;Display the MPI Primary View Rejected Data Report
I '$D(ICN) G EXIT
I '$D(EXCDT) G EXIT
S LIN=1,X=0,STR="",TXT=""
I '$D(^XTMP("RGPVREJ"_ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP
I '$D(^XTMP("RGPVREJ",ICN,EXCDT)) S TXT=" - No Primary View Reject data exists for this patient/exception date." D ADDTMP
N STATUS,R,RETURN,RESULT,RET
I $D(^XTMP("RGPVREJ"_ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ"_ICN,EXCDT),"^") D
I $D(^XTMP("RGPVREJ",ICN,EXCDT)) S RETURN(0)=$P(^XTMP("RGPVREJ",ICN,EXCDT),"^") D
.D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D
..;Retrieve the data
..D RTNDATA^XWBDRPC(.RET,RETURN(0)) D

19
r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEXHND1.m
View File

@ -1,5 +1,5 @@
RGEXHND1 ;BAY/ALS-MPI/PD EXCEPTION HANDLING UTILITY ;10/08/99
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45,52**;30 Apr 99;Build 2
;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,23,43,45**;30 Apr 99;Build 9
DTLIST ;List exceptions by date
K ^TMP("RGEXC",$J)
I '$D(RGBG) S VALMBG=1
@ -19,7 +19,7 @@ DTLIST ;List exceptions by date
... F S IEN2=$O(^RGHL7(991.1,IEN,1,IEN2)) Q:'IEN2 D
.... S EXCTYP=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",3)
....;don't include 234 below; those were done first (above).
.... I EXCTYP=218 D ADDREC ;**45;MPIC_772; **52 remove 215, 216, and 217
.... I ((EXCTYP>214)&(EXCTYP<219)) D ADDREC ;**45
K I,NUM,EXCDT,EXCTYP,RGBG
IF CNT<1 D NDATA
Q
@ -36,7 +36,7 @@ EXCLST ;List exceptions by type
S CNT=0,EXCDT="",EXCTYP=""
I '$D(RGBG) S VALMBG=1
F S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP D
. I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217
. I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45
.. S IEN=0
.. F S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN D
... S NUM="" S NUM=$P($G(^RGHL7(991.1,IEN,1,0)),"^",4) Q:NUM<1 D
@ -52,7 +52,7 @@ PATLST ;List exceptions by patient
S CNT=0,EXCDT="",EXCTYP="",NDX=0,NAME=""
I '$D(RGBG) S VALMBG=1
F S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP D
. I (EXCTYP=234)!(EXCTYP=218) D ;**45;MPIC_772; **52 remove 215, 216, and 217
. I (EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**45
.. S DFN=""
.. F S DFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,DFN)) Q:'DFN D
... S IEN=0
@ -84,13 +84,13 @@ SELTYP ; List all exceptions of type selected by user
I '$D(RGBG) S VALMBG=1
K DIR,Y,DIC
S DIR("A")="Enter an exception type to view: "
S DIR(0)="SAM^218:Potential Matches Returned;234:Primary View Reject" ;**43;**45;MPIC_772; **52 remove 215, 216, and 217
S DIR(0)="SAM^215:Death Entry on MPI not VISTA;216:Death Entry on Vista not MPI;217:Death Entries on MPI and Vista DON'T MATCH;218:Potential Matches Returned;234:Primary View Reject" ;**43,45
S DIR("?")="^D HLPSEL^RGEXHND1"
D ^DIR
I Y<1 S RGSORT="SD" D SORT^RGEX01 Q
Q:$D(DUOUT)!$D(DTOUT)
S EXCTYPE=+Y,ETYPE=$P(^RGHL7(991.11,EXCTYPE,10),"^",1)
I (EXCTYPE=234)!(EXCTYPE=218) S FLAG=1 ;**43;**45;MPIC_772; **52 remove 215, 216, and 217
I (EXCTYPE=234)!((EXCTYPE>214)&(EXCTYPE<219)) S FLAG=1 ;**43,45
I FLAG=1 D ADDSEL
E I FLAG=0 D
. W !,"Not a valid selection."
@ -116,6 +116,9 @@ ADDSEL ;called by SELTYP
HLPSEL ;
D FULL^VALM1
;W !,"The following exception types are handled by this option:"
;W !!,"Death Entry on MPI not in VISTA",?50,"(215)"
;W !,"Death Entry on Vista not in MPI",?50,"(216)"
;W !,"Death Entries on MPI and Vista DO NOT MATCH",?50,"(217)"
;W !,"Potential Matches Returned",?50,"(218)"
;W !,"Primary View Reject",?50,"(234)"
S VALMBCK="R"
@ -129,8 +132,8 @@ ADDREC ;
S HOME=$$SITE^VASITE()
I (STAT<1)!(STAT="") D
.;Only list exceptions that are Not Processed
.; only list patients with local ICN, or for exceptions 234 or 218;MPIC_772; **52 remove 215, 216, and 217
. I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!(EXCTYP=218) D ;**43,**45,**52
.; only list patients with local ICN, or for exceptions 234, 215 - 218
. I $E(ICN,1,3)=$E($P(HOME,"^",3),1,3)!(ICN<0)!(EXCTYP=234)!((EXCTYP>214)&(EXCTYP<219)) D ;**43,45
.. S DFN=RGDFN D DEM^VADPT
.. S RGNM=VADM(1)
.. S RGSSN=$P($G(VADM(2)),"^",1)

65
r/CLINICAL_PROCEDURES-MD/MDAPI.m
View File

@ -1,10 +1,10 @@
MDAPI ; HOIFO/DP/NCA - CP API Calls ; [05-05-2003 10:28]
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Description:
; These API's are for use by external packages communicating with CP.
;
; Integration Agreements:
; IA# 3378 [Subscription] Documents the APIs that external packages use to communicate with CP.
; IA# 3378 [Restricted] Documents the APIs that external packages use to communicate with CP.
; IA# 3468 [Subscription] Use GMRCCP APIs.
;
EXTDATA(MDPROC) ; [Procedure]
@ -137,17 +137,15 @@ TIUDEL(MDNOTE) ; [Procedure] TIU Note deletion Update
; Input parameters
; 1. MDNOTE [Literal/Required] TIU IEN
;
N MDGBL,MDRES,MDFDA,MDTRAN,RESULTS
N MDRES,MDFDA,RESULTS
S MDRES="" F S MDRES=$O(^MDD(702,"ATIU",MDNOTE,MDRES)) Q:'MDRES D
.Q:$G(^MDD(702,+MDRES,0))=""
.;S MDFDA(702,MDRES_",",.05)=""
.S MDFDA(702,MDRES_",",.05)=""
.S MDFDA(702,MDRES_",",.06)=""
.D FILE^DIE("","MDFDA")
.S MDTRAN=$O(^MDD(702.001,"ASTUDY",MDRES,MDNOTE,0)) I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK
.D STATUS^MDRPCOT(MDRES_",",2,"TIU note deleted.")
.S DATA("TRANSACTION")=MDRES,DATA("PKG")="TIU"
.S DATA("MESSAGE")="TIU note deleted." D RPC^MDRPCOT(.RESULTS,"ADDMSG",.DATA)
S MDGBL=$NA(^MDD(702.001,"PK",MDNOTE)) F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDNOTE) S MDTRAN=$QS(MDGBL,6) N DA,DIK S DA=+MDTRAN,DIK="^MDD(702.001," D ^DIK
Q 1
;
TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an API to clean up and update TIU note re-assignment.
@ -160,7 +158,7 @@ TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an
; 6. MDNEWV [Literal/Required] The new visit for the TIU document assignment.
; 7. MDNTIU [Literal/Required] The new reassigned TIU document IEN.
;
N MDD,MDGBL,MDTRAN,MDCHK,MDLP,MDMULN,MDN,MDPPR,MDREAS,MDTRANI,MDX
N MDD,MDTRAN,MDCHK,MDLP,MDPPR,MDREAS,MDTRANI,MDX
I '$G(MDFN) Q "0^No DFN for the TIU note re-assignment."
I '$G(MDOLDC) Q "0^No Old Consult # for the note re-assignment."
I '$G(MDANOTE) Q "0^No TIU Note IEN."
@ -168,28 +166,19 @@ TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an
I '$G(MDNEWC) Q "0^No New Consult # for the note assignment."
I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN."
S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J)
S MDTRAN=$O(^MDD(702,"ATIU",MDANOTE,0)) I +MDTRAN S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," D
F S MDTRAN=$O(^MDD(702,"ACON",MDOLDC,MDTRAN)) Q:'MDTRAN D
.S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_","
.I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D
..S MDFDA(702,+MDTRAN_",",.06)=""
..D FILE^DIE("","MDFDA") K MDFDA
S MDGBL=$NA(^MDD(702.001,"PK",MDANOTE))
F S MDGBL=$Q(@MDGBL) Q:MDGBL="" Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDANOTE) S MDN=$QS(MDGBL,6) N DA,DIK S DA=+MDN,DIK="^MDD(702.001," D ^DIK
S MDMULN=+$O(^MDD(702.001,"ASTUDY",+MDTRAN,0))
I '+MDMULN I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
D NOW^%DTC S MDD=% S MDTRANI=$O(^MDD(702,"ACON",MDNEWC,0))
S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
I +MDTRANI&(MDNDFN=+$G(^MDD(702,+MDTRANI,0))) D
.S MDPPR=$P($G(^MDD(702,+MDTRANI,0)),"^",4) Q:'MDPPR
.S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
.S MDFDA(702,+MDTRANI_",",.06)=MDNTIU
.S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
.D FILE^DIE("","MDFDA") K MDFDA
..S:'MDPPR MDPPR=$P(MDCHK,U,4)
..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
I 'MDPPR D
.D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J)))
.S MDX=""
.F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX S:$P(^(MDX),U,5)=MDNEWC MDPPR=$P(^(MDX),U,6)
K ^TMP("MDTMP",$J)
I +MDPPR Q 1
I 'MDPPR Q 1
D NOW^%DTC S MDD=%
S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
S MDFDA(702,"+1,",.01)=MDNDFN
S MDFDA(702,"+1,",.02)=MDD
@ -199,7 +188,7 @@ TIUREAS(MDFN,MDOLDC,MDANOTE,MDNDFN,MDNEWC,MDNEWV,MDNTIU) ; [Function] This is an
S MDFDA(702,"+1,",.06)=MDNTIU
S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
S MDFDA(702,"+1,",.09)=0
D UPDATE^DIE("","MDFDA")
D UPDATE^DIE("","MDFDA","MDTRANI") Q:'$G(MDTRANI(1)) 1
Q 1
;
TRANS(STR) ; [Function] Translate the upper arrows to blanks
@ -209,31 +198,3 @@ TRANS(STR) ; [Function] Translate the upper arrows to blanks
I STR["^" Q $TR(STR,"^"," ")
Q STR
;
GETCP(RESULTS,MDCSLT) ; API to return CP Study data
; Input Parameters:
; 1. RESULTS [Literal/Required] Return Array
; 2. MDCSLT [Literal/Required] Consult number
;
; Output:
; RESULTS(0)=-1^Error Message or 1 for success
; (N,1)=CP Study Number
; (N,2)=Patient DFN
; (N,3)=Created Date/Time
; (N,4)=Created By
; (N,5)=CP Definition (External Name)
; (N,6)=Consult Number
; (N,7)=TIU Note IEN
; (N,8)=VSTR
; (N,9)=Transaction Status
;
; Where N = 1..n entries
;
N MDCT,MDX,MDY
I '$G(MDCSLT) S @RESULTS@(0)="-1^No Consult Number passed" Q
S MDX=$O(^MDD(702,"ACON",MDCSLT,0)) I 'MDX S @RESULTS@(0)="-1^No CP Study Entry." Q
S @RESULTS@(0)=1
S MDCT=0,MDX="" F S MDX=$O(^MDD(702,"ACON",MDCSLT,MDX)) Q:MDX<1 D
.S MDCT=MDCT+1,@RESULTS@(MDCT,1)=MDX
.S MDY=$G(^MDD(702,+MDX,0)),@RESULTS@(MDCT,2)=$P(MDY,U),@RESULTS@(MDCT,3)=$P(MDY,U,2),@RESULTS@(MDCT,4)=$P(MDY,U,3),@RESULTS@(MDCT,5)=$$GET1^DIQ(702,+MDX,.04,"E")
.S @RESULTS@(MDCT,6)=$P(MDY,U,5),@RESULTS@(MDCT,7)=$P(MDY,U,6),@RESULTS@(MDCT,8)=$P(MDY,U,7),@RESULTS@(MDCT,9)=$$GET1^DIQ(702,+MDX,.09,"E")
Q

45
r/CLINICAL_PROCEDURES-MD/MDHL7A.m
View File

@ -1,10 +1,9 @@
MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07 08:17
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38]
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Reference DBIA #10035 [Supported] for DPT calls.
; Reference DBIA #10106 [Supported] for HLFNC calls.
; Reference DBIA #10062 [Supported] for VADPT6 calls.
; Reference DBIA #2701 [Supported] for MPIF001 calls
; Reference DBIA #10096 [Supported] for ^%ZOSF calls
; Reference DBIA #2701 [Supported] for MPIF001 Calls
EN ; [Procedure] Entry Point for Message Array in MSG
N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
N I,ICNT,ID,IMP,J,K,LBL,LINO,LINE,LN,MDAPP,MDRTN,MG,MSG,N,NAM,NEXT,NUM
@ -12,25 +11,15 @@ EN ; [Procedure] Entry Point for Message Array in MSG
N UNITS,VA,VAL,X,XMBODY,XMDUZ,XMSUBJ,XMTO,Z,ZZ,Z1,Z2,MDERROR
N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
N MDIORD
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1")
K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
S MDFLAG=0,MDERROR=0,MDQFLG=0
Q:$G(HLMTIENS)=""
S ^TMP($J,"MDHL7A1")=""
S HLREST="^TMP($J,""MDHL7A1"")"
S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6**
I $P(X,U)=0 D Q
. S DEVIEN=0,ECODE=0
. S ERRTX=$P(X,U,2)
. D ^MDHL7X
. Q
I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A")
K HLNODE,^TMP($J,"MDHL7A1")
F I=1:1 X HLNEXT Q:MDQFLG S ^TMP($J,"MDHL7A",I)=$TR(HLNODE,$C(10),""),J=0 S:HLQUIT<1 MDQFLG=1 F S J=$O(HLNODE(J)) Q:J<1 S ^TMP($J,"MDHL7A",I,J)=$TR(HLNODE(J),$C(10),"")
K HLNODE
;
EN2 ; [Procedure] No Description
S (DEVIEN,DEVNAME)="",I=0
S (DEVIEN,DEVNAME)=""
F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X="" Q:$E(X,1,3)="OBX" D
. S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4)
. I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN")
. I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
. I $E(X,1,3)="OBR" D
.. I DEVNAME="Instrument Manager" D
@ -57,8 +46,11 @@ EN2 ; [Procedure] No Description
. Q
I (ZCODE="M")!(ZCODE="B") D Q:MDERROR Q:ZCODE="M" ;
. S MDFLAG=1,MDERROR=0 ; Tell Medicine that CP is talking to HL7
. ;S MSG(1)=^TMP($J,"MDHL7A",1)
. ;S MSG(2)=^TMP($J,"MDHL7A",2)
. D ^MDHL7MCA ; Run the Medicine routines
. Q:MDERROR ; Medicine found an error and sent an error back
. ;;I ZCODE="M" D GENACK^MDHL7X
. Q
S NUMZ=$O(^TMP($J,"MDHL7A",""),-1)
S NUM=0,MDOBX=0
@ -103,13 +95,11 @@ OBR ; [Procedure] Check OBR
S SEG("OBR")=X
S MDIORD=$P(X,"|",4)
S MDD702=$S(+MDIORD<1:"",1:$$GETSTDY^MDRPCOT1(MDIORD))
;I MDD702'="" S MDD702=$$CHK^MDNCHK(MDD702) ; PATCH 11
S ORIFN=$P(X,"|",3),(EXAM,%)=$P(X,"|",5) I EXAM'="" S EXAM=$P(%,"^",2) I EXAM="" S EXAM=$P(%,"^",1)
S CPT=$P(X,"|",5) I $P(CPT,"^",3)["CPT" S CPT=$P(CPT,"^",1)
S DTO="",DATE=$P(X,"|",8) I DATE'="" S:$L(DATE)>14 DATE=$E(DATE,1,14) S DTO=$$FMDATE^HLFNC(DATE)
; vvv== Added to address the issues of mismatch
I $G(MDD702)>0 I DFN'=$$GET1^DIQ(702,MDD702,.01,"I") S ERRTX="Patient name Mismatch. Name in PID doesn't match the name in the CP Order #"_MDD702_"." D ^MDHL7X Q
I $G(MDD702)>0 I MDDOB'=$$GET1^DIQ(2,DFN,.03,"I") S ERRTX="Patient DOB Mismatch. DOB in PID doesn't match the DOB in the CP Order #"_MDD702_"." D ^MDHL7X Q
I DTO="" S ERRTX="Missing required Date/Time of Procedure in OBR" D ^MDHL7X Q
;;S UNIQ=$TR($H,",","-")
S UNIQ=$$NEWID(DFN,DATE,INST,$G(MDD702),HLMTIEN)
@ -118,14 +108,11 @@ OBR ; [Procedure] Check OBR
N SET S SET=DTO_"^"_$P(UNIQ,U,2),ICNT=0 N IMP
S MDRTN=$P($G(^MDS(702.09,INST,.1)),"^",1) S:MDRTN'["^" MDRTN="^"_MDRTN
S X=MDRTN S:X["^" X=$P(X,"^",2) X ^%ZOSF("TEST") I '$T S ERRTX="Processing routine not found" D ^MDHL7X Q ; IA %10096
D CPTICD^MDHL7U3(X,MDIEN) ; Update CPT and ICD9
D PHY^MDHL7U3(X,MDIEN) ; Get Doc who did the procedure.
Q
;
PID ; [Procedure] Check PID
S X=$G(^TMP($J,"MDHL7A",NUM)) I $E(X,1,3)'="PID" S ERRTX="PID not second record" D ^MDHL7X Q
S SEG("PID")=X
S MDDOB=$P(X,"|",8) I MDDOB'="" S MDDOB=($E(MDDOB,1,4)-1700)_$E(MDDOB,5,8)
I $L($P(X,"|",4))'<16 D I +DFN=-1 Q
. N ICN
. S ICN=$P(X,"|",4)
@ -153,15 +140,16 @@ MDSSN ; This subroutine is to match up the SSN for a patient.
Q
;
OBX ; [Observation]
;Q:$P(^TMP($J,"MDHL7A",NUM),"|")'="OBX"
D @MDRTN
Q
NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
N NEWID,MDFDA,MDIEN,MDNO
N NEWID,MDFDA,MDIEN
S NEWID=$TR($H,",","-") ; Create inital ID
L +(^MDD(703.1,"B")):60 E Q "-1"
;^^--- Unable to get a lock in the file
;^^--- Unable to get an lock in the file
F Q:'$D(^MDD(703.1,"B",NEWID)) H 1 S NEWID=$TR($H,",","-")
;^^--- Search to create a new ID if current ID is in use
;^^--- Search to create an new ID in current ID is in use
S MDFDA(703.1,"+1,",.01)=NEWID
S MDFDA(703.1,"+1,",.02)=DFN
S MDFDA(703.1,"+1,",.03)=$$HL7TFM^MDHL7U(DATE)
@ -170,10 +158,7 @@ NEWID(DFN,DATE,INST,MDD702,HLMTIEN) ; Generate a new entry and ID of 703.1
S MDFDA(703.1,"+1,",.06)=HLMTIEN
D UPDATE^DIE("","MDFDA","MDIEN")
L -(^MDD(703.1,"B"))
I $G(MDIEN(1))>0 D Q MDIEN(1)_U_NEWID
. S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
. S MDNO=$$NTIU^MDRPCW1(+MDD702)
. Q
I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID
; ^^--- Create Subfile and quit
Q "-1" ; Unable to create file
;

6
r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m
View File

@ -1,9 +1,8 @@
MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Reference DBIA #10035 for DPT calls.
; Reference DBIA #10062 for VADPT calls.
; Reference DBIA #10106 for HL7 calls.
; Reference DBIA #10096 for ^%ZOSF calls.
EN ; Entry Point for Message Array in MSG
N MSG
K ERRTX
@ -37,6 +36,7 @@ PID ; Check PID
LPOBR I $E(MSG(NUM),1,3)'="OBR" S NUM=NUM+1 G LPOBR
;I $E(MSG(NUM),1,3)="ORC" S NUM=NUM+1
OBR ; Check OBR
W MSG(NUM)
S X=$G(MSG(NUM)) I $E(X,1,3)'="OBR" S ERRTX="OBR not found when expected" D ^MDHL7MCX G KIL
S SEG("OBR")=X
S ORIFN=$P(X,"|",3),INST=$P(X,"|",25) I MCAPP="Instrument Manager",INST'="" S MCAPP=INST

202
r/CLINICAL_PROCEDURES-MD/MDHL7U3.m
View File

@ -1,47 +1,6 @@
MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages ; 7/26/00
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
; Reference DBIA #2729 [Supported] for XMXPAI
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Reference DBIA #4262 [Supported] for HL7 call.
; Reference DBIA #3273 [Subscription] for HL7 call.
; Reference DBIA #10138 [Supported] for HL7 call.
; Reference DBIA #3990 [Supported] for ICDCODE call
; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference
; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
; Reference DBIA #10082 [Supported] for ^ICD9 reference
; Reference DBIA #10111 [Supported] for FILE 3.8 call
; Reference DBIA #10103 [Supported] for XLFDT call
;
HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient.
N X
S X="1^"
D
. N Y
. I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q
. I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q
. S Y=0
. S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file."
. Q
Q X
XVERT(MDA,MDB) ; Strip out blank Lines
Q:MDA=""
Q:MDB=""
Q:$G(^TMP($J,MDA,1))
N I,CNT,CNT2,NODE,FLG
S (CNT,I,FLG)=0
F S I=$O(^TMP($J,MDA,I)) Q:I<1 D
. S NODE=$TR(^TMP($J,MDA,I),$C(10),"")
. I NODE="" S FLG=0 Q
. I FLG D Q
. . S CNT2=CNT2+1
. . S ^TMP($J,MDB,CNT,CNT2)=NODE
. . Q
. I 'FLG D Q
. . S CNT=CNT+1
. . S ^TMP($J,MDB,CNT)=NODE
. . S FLG=1,CNT2=0
. . Q
. Q
Q
;
PURGE(MDD7031) ;
; This sub-routine will delete HL7 772 Message text after a message
@ -51,162 +10,3 @@ PURGE(MDD7031) ;
D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")")
S $P(^MDD(703.1,MDD7031,0),U,6)=""
Q
;
PHY(X,MDIEN) ; Add the doc who did the exam to the report
Q
; This will be implemented with the Doctor Lookup when it comes out.
N LINE1,LINE
S LINE1=$P(X,"|",17)
S LINE=$P(LINE1,"^",2) ; Last
S LINE=LINE_$S($P(LINE1,"^",3)'="":", "_$P(LINE1,"^",3),1:"") ; First
S LINE=LINE_$S($P(LINE1,"^",4)'="":" "_$P(LINE1,"^",4),1:"") ; MI
D ADD(MDIEN,"9",LINE)
Q
;
CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes
N ICD,CPT
Q:MDIEN<1
S CPT=$P(X,"|",45) I CPT'="" D FILECD(MDIEN,CPT,"7")
S ICD=$P(X,"|",14) I ICD'="" D FILECD(MDIEN,ICD,"8")
Q
FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA
N LINE,Y,I,CNT,RESULT
S CNT=$L(CODE,"~")
S LINE=""
F I=1:1:CNT S Y=$P(CODE,"~",I),RESULT=$P(Y,"^",1),LINE(.2,I,0)=RESULT
S LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$P(%,".")
Q:CNT<1 ; file the results if there is any
D ADD(MDIEN,TYPE,.LINE,CNT)
Q
;
ADD(MDIEN,TYPE,LINE,CNT) ;
; Create an entry in the .1 node
N NODE,X
S NODE=$G(^MDD(703.1,MDIEN,.1,0)) Q:NODE=""
S NODE=$P(NODE,"^",3)
S NODE=NODE+1
S $P(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE
S $P(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE
D NOW^%DTC
M ^MDD(703.1,MDIEN,.1,NODE)=LINE
Q
;
MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS to the array in MDHLREST
; Only TCP type messages
; input: MDHLIENS= the intern entry number of the message in ^HLMA
; MDHLREST = the return array that will contain the whole HL7 message
; output: return "1^Message complete" if message was successful, "0^reason" if failed.
;
N MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET
S (MDHLCNT,MDHLI,RET)=0
I $G(MDHLIENS)="" S RET=RET_"^No IEN defined" Q RET ; Exit because no IEN for ^HLMA was provided
I $G(MDHLREST)="" S RET=RET_"^No Return ARRAY provided" Q RET ; Exit because no return array was provided
I $G(^HLMA(MDHLIENS,0))="" S RET=RET_"^HLMA entry does not exist" Q RET ; Exit because invalid OR non-EXISTING HLMA ENTRY
S MDHLIEN=$P(^HLMA(MDHLIENS,0),U)
I MDHLIEN="" S RET=RET_"^No pointer value to file 772" Q RET ; No Pointer to 772
I $G(^HL(772,MDHLIEN,0))="" S RET=RET_"^772 Entry does not exist" Q RET ; No 772 entry exist
;get header
S MDHLZ=$G(^HLMA(MDHLIENS,"MSH",1,0))
I MDHLZ="" S RET=RET_"^No MSH segment found" Q RET ; No MSH was found
S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=MDHLZ
S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=""
;get body
S MDHLI=0
F S MDHLI=$O(^HL(772,MDHLIEN,"IN",MDHLI)) Q:'MDHLI D
. S MDHLCNT=MDHLCNT+1
. S @MDHLREST@(MDHLCNT)=$G(^HL(772,MDHLIEN,"IN",MDHLI,0))
. Q
I MDHLCNT'>2 S RET=RET_"^No message body found" Q RET ; There was no body
S RET="1^Message complete"
Q RET
;
CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results
;in the indicated global
N NODE,FLG
S FLG=1
Q:MDIEN="" ; The ien was null
Q:RETURN="" ; the array was null
S ARRAY(0)="0^0"
I $G(^MDD(703.1,MDIEN,.1,0))="" S FLG=0 Q ; There is not data.
; Start the processing of ICD/POV codes Value is 8
S NODE=0
I FLG I $G(^MDD(703.1,MDIEN,.1,0))'="" D
. F S NODE=$O(^MDD(703.1,MDIEN,.1,NODE)) Q:NODE<1 D
. . S TYPE=$P($G(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1)
. . I TYPE=8 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
. . I TYPE=7 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
. . Q
. Q
M @RETURN=ARRAY
Q
PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each
N CNT,X,CONT,CODE,AR,TP,LOC
S CNT=0,CONT=0
F S CNT=$O(^MDD(703.1,MDIEN,.1,NODE,.2,CNT)) Q:CNT<1 D
. S CODE=$G(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"") ; Grabbing the ICD9 AND CPT codes
. I CODE="" Q
. I TYPE=8 S AR=1,TP="POV",X=$$ICDDX^ICDCODE(CODE) Q:X="" ; Reference DBIA #3990 [Supported] for ICDCODE call
. I TYPE=7 S AR=2,TP="CPT",X=$$CPT^ICPTCOD(CODE) Q:X="" ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
. S CONT=CONT+1
. S ARRAY(AR)=CONT_"^"_CONT
. I AR=1 D
. . N DESC,IN,LN
. . S IN=$P(X,"^",1) Q:IN<1
. . S LN=$G(^ICD9(IN,0),0) Q:LN=""
. . S DESC=$P(LN,"^",3) Q:DESC=""
. . S I=CONT
. . S $P(ARRAY(AR,I),"^",1)=TP
. . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
. . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
. . S $P(ARRAY(AR,I),"^",5)=DESC
. . S $P(ARRAY(AR,I),"^",6)=$S(I=1:1,1:0)
. . Q
. I AR=2 D
. . N DESC,IN,LN
. . S IN=$P(X,"^",1) Q:IN<1
. . ; S LN=$G(^ICPT(IN,0),0) Q:LN=""
. . S DESC=$P(X,"^",3) Q:DESC="" ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC
. . S I=CNT
. . S $P(ARRAY(AR,I),"^",1)=TP
. . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
. . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
. . S $P(ARRAY(AR,I),"^",5)=DESC
. . S $P(ARRAY(AR,I),"^",7)=$S(I=1:1,1:0)
. . Q
. Q
I $D(ARRAY(1))!$D(ARRAY(2)) S ARRAY(0)="1^1"
Q
;
NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted
;
N INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X
S MG=0
S INST=DEVIEN
I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2)
I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
S MG=$$GET1^DIQ(3.8,+MG_",",.01)
S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
S XMBODY="TXT"
S XMSUBJ=SUBJECT
D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
Q
;
ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted
D NOW^%DTC
S SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!"
S BODY(1)="The following study has been deleted."
S BODY(2)=" By the USER: "_$$GET1^DIQ(200,DUZ,.01,"E")
S BODY(3)=" On Date: "_$$FMTE^XLFDT(%,1)
S BODY(4)=" "
S BODY(5)=" CP Study Information"
S BODY(6)="------------------------------------------------------------------------------ "
S BODY(7)="CP Study ID: "_MDSIEN
S BODY(8)="CP Study Def: "_$$GET1^DIQ(702,MDSIEN,.04,"E")
S BODY(9)="Created on: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1)
S BODY(10)="Created by: "_$$GET1^DIQ(702,MDSIEN,.03,"E")
S BODY(11)="On Instrument: "_$$GET1^DIQ(702,MDSIEN,.11,"E")
S BODY(12)="For Patient: "_$$GET1^DIQ(702,MDSIEN,.01,"E")
S BODY(13)=" SSN: "_$E($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9)
S BODY(14)=" DOB: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1)
S DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I")
Q

6
r/CLINICAL_PROCEDURES-MD/MDHL7X.m
View File

@ -1,5 +1,5 @@
MDHL7X ; HOIFO/WAA -Generate HL7 Error Message ; 06/08/00
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Reference IA #1131 for ^XMB("NETNAME") access.
; Reference IA #2165 for HLMA1 calls.
; Reference IA #2729 for XMXAPI calls.
@ -11,10 +11,10 @@ GENERR ; Generate error message
I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
S MG=$$GET1^DIQ(3.8,+MG_",",.01)
S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
I '$D(X) S X=$G(ECODE(0))
I '$D(X) S X=ECODE(0)
S TXT(1)=ERRTX,TXT(2)=X,TXT(3)=" "
S N=3
I '$G(ECODE,1) D ; This is to process Device errors
I 'ECODE D ; This is to process Device errors
. N X
. S X=0
. F S X=$O(ECODE(X)) Q:X<1 S N=N+1,TXT(N)=ECODE(X)

8
r/CLINICAL_PROCEDURES-MD/MDRPCOG.m
View File

@ -1,5 +1,5 @@
MDRPCOG ; HOIFO/DP - CP Gateway ; [01-09-2003 15:20]
;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
; Description:
; This is the main routine that manages the CLINICAL PROCEDURES Gateway functions.
; Access to these functions is controlled via the MD GATEWAY RPC.
@ -115,12 +115,6 @@ RPC(RESULTS,OPTION,DATA,P1) ; [Procedure]
D @OPTION
Q
;
RUNNING ; [Procedure] Returns 0/1 and message on running status
; Note: If lock CAN be obtained, then gateway is NOT running
L +^MDD("CPGATEWAY"):1 E S @RESULTS@(0)="1^RUNNING" Q
L -(^MDD("CPGATEWAY")) S @RESULTS@(0)="0^NOT RUNNING"
Q
;
SETFILE ; [Procedure] Set filename of new attachment
S MDFDA(703.11,$P(DATA,U,1),.02)=$P(DATA,U,2)
D FILE^DIE("","MDFDA")

117
r/CLINICAL_PROCEDURES-MD/MDRPCOP.m
View File

@ -1,20 +1,21 @@
MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08 09:16
;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102
MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21]
;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3
; Integration Agreements:
; IA# 2263 [Supported] XPAR calls
; IA# 3027 [Supported] Calls to DGSEC4
; IA# 2981 [Subscription] Calls to GUI~GMRCP5
; IA# 2548 [Supported] ACRP Interface Toolkit APIs.
; IA# 2552 [Supported] AIT API to provide outpatient encounter data.
; IA# 10061 [Supported] VADPT calls.
; IA# 3468 [Subscription] Use GMRCCP APIs.
; IA# 3266 [Subscription] Call to DPTLK1
; IA# 10103 [Supported] Call to XLFDT
; IA# 10039 [Supported] Ward Location File (#42) Access.
; IA# 10035 [Supported] DPT references
; IA# 3267 [Subscription] Call to DPTLK1
; IA# 3593 [Supported] Access to routine DPTLK6 utilities for lookup
; IA# 3613 [Private] GETVST^MDRPCOP API call
; IA# 10099 [Supported] GMRADPT call
; IA# 1096 [Controlled Subscription] ^DGPM("ATID1" x-ref loop
; IA# 358 [Controlled Subscription] FILE 405 references
;
ADD(X) ; [Procedure] Add line to @RESULTS@(...
S @RESULTS@(+$O(@RESULTS@(""),-1)+1)=X
@ -49,14 +50,6 @@ CHKIN ; [Procedure] Check In Study
.I +MDHL7=-1 S MDFDA(702,MDIENS,.09)=2,MDFDA(702,MDIENS,.08)=$P(MDHL7,U,2)
.I +MDHL7=1 S MDFDA(702,MDIENS,.09)=5,MDFDA(702,MDIENS,.08)=""
.D:$D(MDFDA) FILE^DIE("","MDFDA","MDERR")
; Patch 6 - Renal Check-In
D:+$G(MDIENS)
.S X=+$P(^MDD(702,+MDIENS,0),U,4) Q:'X
.I $P(^MDS(702.01,X,0),U,6)=2 D Q ; Renal Check-In
..D CP^MDKUTLR(+MDIENS)
..S MDFDA(702,+MDIENS_",",.09)=5
..D FILE^DIE("","MDFDA","MDERR")
; Patch 6 - Renal Check-In
I '$D(MDERR) S @RESULTS@(0)="1^OK" Q
D ERROR^MDRPCU(RESULTS,.MDERR)
Q
@ -67,14 +60,11 @@ DISPCON ; [Procedure] Display a consult
Q
;
GETCONS ; [Procedure] Get available consults for patient
K ^TMP("MDTMP",$J) N MDCDT,MDDY,X1,X2,X
S MDDY=$$GET^XPAR("SYS","MD COMPL PROC DISPLAY DAYS",1)
S X1=DT,X2=-$S(MDDY>0:+MDDY,1:365) D C^%DTC S MDCDT=X
K ^TMP("MDTMP",$J)
D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
S MDX=0
F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4)
.S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5)
.I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
.F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X)
.S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5)))
.;
@ -123,35 +113,17 @@ GETRES ; [Procedure] Get results report
Q
;
GETTRAN ; [Procedure] Get a patients transactions
K ^TMP("MDTMP",$J),^TMP("MDCONL",$J) N MDCDT,MDCOM,MDMULT,MDNUM,MDREQ,MDREQDT,MDYR,X1,X2,X
S MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1) S MDCOM=0
I +MDNUM>0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X
D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
S X1=DT,X2=-365 D C^%DTC S MDCDT=X
S MDX=0 F S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4)
.I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
.S ^TMP("MDCONL",$J,$P($G(^TMP("MDTMP",$J,MDX)),U,5))=$P($G(^TMP("MDTMP",$J,MDX)),U,1)
K ^TMP("MDTMP",$J)
F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D
.Q:'$$GET1^DIQ(702,MDX,.05,"I")
.Q:$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))=""
.S MDMULT=+$$GET1^DIQ(702,MDX,".04:.12","I")
.S MDYR=$S(MDMULT<1:MDCOM,1:MDCDT)
.I MDNUM Q:$$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDYR)
.S MDREQDT="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDREQDT=$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))
.I MDREQDT'="" S MDREQDT=$$FMTE^XLFDT(MDREQDT,"1P")
.S MDREQ=$$GET1^DIQ(702,MDX,.04)_" "_+MDX_" (Consult #:"_$$GET1^DIQ(702,MDX,.05,"I")_$S(MDREQDT'="":" Requested: "_MDREQDT,1:"")_")"
.S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_MDREQ_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991)
.S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_$$GET1^DIQ(702,MDX,.04)_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991)
.S Y=$O(@RESULTS@(""),-1)+1
.S @RESULTS@(Y)="702;"_+MDX_U_Z
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
K ^TMP("MDCONL",$J)
Q
;
GETVST ; [Procedure] Return list of visits
N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,MDTDF,STI,STS,TODAY,I,J,K,XI,XE,X
S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1),MDTDF=DFN
S BEG=$$X2FM($$GETBEG),END=$$X2FM($$GETEND)+0.2359
N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,STI,STS,TODAY,I,J,K,XI,XE,X
S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
S BEG=$$X2FM("T-200"),END=$$X2FM("T")+0.2359
S MDLST="",MDSTOP=""
I END>NOW D ; get future encounters, past cancels/no-shows from VADPT
.S VASD("F")=BEG
@ -178,7 +150,7 @@ GETVST ; [Procedure] Return list of visits
.I '$$ERRCHK^SDQUT() D SCAN^SDQ(.MDQUERY,"FORWARD")
.D CLOSE^SDQ(.MDQUERY)
N TIM,MOV,MDX0,Y,MTIM,XTYP,XLOC,XLOCI,HLOC,EARLY,DONE ; admits
S EARLY=BEG,DONE=0 S:$G(DFN)="" DFN=MDTDF
S EARLY=BEG,DONE=0
S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE
.S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE
..D GETS^DIQ(405,+MOV_",","*","IE","MDX0") S MTIM=$G(MDX0(405,MOV_",",".01","I"))
@ -191,19 +163,12 @@ GETVST ; [Procedure] Return list of visits
.S J="" F S J=$O(MDLST(I,J)) Q:J="" D
..S K=0 F S K=$O(MDLST(I,J,K)) Q:'K D
...S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDLST(I,J,K)
S:$G(DFN)="" DFN=MDTDF S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
Q
;
GETBEG() ; Get Beginning Date Range
I $$GET^XPAR("SYS","MD APPOINT START DATE",1)>1 Q "T-"_$$GET^XPAR("SYS","MD APPOINT START DATE",1)
Q "T-200"
GETEND() ; Get Ending Date Range
I $$GET^XPAR("SYS","MD APPOINT END DATE",1)>1 Q "T+"_$$GET^XPAR("SYS","MD APPOINT END DATE",1)
Q "T"
LOGSEC ; [Procedure] Log Security
N RES
D NOTICE^DGSEC4(.RES,DFN,DATA,1)
S @RESULTS@(0)=$S(+RES:"1^Logged",1:"-1^Unable to log")
D NOTICE^DGSEC4(.RESULTS,DFN,DATA,1)
S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log")
Q
;
RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag
@ -215,8 +180,58 @@ RPC(RESULTS,OPTION,DFN,DATA) ; [Procedure] Main RPC call tag
Q
;
SELECT ; [Procedure] Select patient
; Moved to continuation routine at MD*1.0*6 due to routine size
D SELECT^MDRPCOP1
I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q
S @RESULTS@(0)="1^Required Identifiers & messages"
S IENS=DFN_","
D FILE^DID(2,,"REQUIRED IDENTIFIERS","MDIDS")
F MDX=0:0 S MDX=$O(MDIDS("REQUIRED IDENTIFIERS",MDX)) Q:'MDX D
.S MDFLD=MDIDS("REQUIRED IDENTIFIERS",MDX,"FIELD")
.S MDID="$$PTID^"_$$GET1^DID(2,MDFLD,"","LABEL")
.S MDID=MDID_U_$$GET1^DIQ(2,IENS,MDFLD)
.D:MDFLD=.03
..S MDID=MDID_" ("_$$GET1^DIQ(2,IENS,.033)_")"
..S MDID=MDID_U_$$DOB^DPTLK1(+IENS)
.D:MDFLD=.09
..S X=$P(MDID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
..S $P(MDID,U,3)=X,$P(MDID,U,4)=$$SSN^DPTLK1(+IENS)
.S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
S MDID="$$PTID^"_$$GET1^DID(2,.1,"","LABEL")
S MDID=MDID_U_$$GET1^DIQ(2,IENS,.1)
S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
S MDID="$$PTID^"_$$GET1^DID(2,.101,"","LABEL")
S MDID=MDID_U_$$GET1^DIQ(2,IENS,.101)
S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
K MDRET
D GUIBS5A^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
.D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4")
.S MDX=1
.F S MDX=$O(MDRET(MDX)) Q:'MDX!(+$G(MDRET(MDX))) D
..D ADD($P(MDRET(MDX),U,2))
.D ADD(" ")
.S MDX=1
.F S MDX=$O(MDRET(MDX)) Q:'MDX D:+MDRET(MDX)
..S MDDFN=+$P(MDRET(MDX),U,2)
..D ADD($$GET1^DIQ(2,MDDFN_",",.01)_" "_$$DOB^DPTLK1(MDDFN)_" "_$$SSN^DPTLK1(MDDFN))
.D ADD(" ")
.D ADD("Please review carefully before continuing")
.D ADD("$$MSGEND")
K MDRET
D PTSEC^DGSEC4(.MDRET,DFN) D:MDRET(1)'=0
.D:MDRET(1)=3
..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!")
.D:MDRET(1)=-1
..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED")
.D:MDRET(1)=1
..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS")
.D:MDRET(1)'=-1&(MDRET(1)'=3)&(MDRET(1)'=1)
..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS")
.S MDX=1
.F S MDX=$O(MDRET(MDX)) Q:'MDX D ADD($TR(MDRET(MDX),"*"," "))
.D ADD("$$MSGEND")
D GUIMTD^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
.D ADD("$$MSGHDR^1^NOTICE")
.F MDX=1:0 S MDX=$O(MDRET(MDX)) Q:'MDX D ADD(MDRET(MDX))
.D ADD("$$MSGEND")
Q
;
X2FM(X) ; [Function] return FM date given relative date

27
r/CLINICAL_PROCEDURES-MD/MDRPCOT.m
View File

@ -1,5 +1,5 @@
MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08 09:18
;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102
MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02 15:33
;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
; Integration Agreements:
; IA# 2693 [Subscription] TIU Extractions.
; IA# 2944 [Subscription] Calls to TIUSRVR1.
@ -21,10 +21,8 @@ ADDMSG ; [Procedure] Add message to transaction
DELETE ; [Procedure] Delete Study
; Sets @RESULTS@(0)="-1^Reason for not deleting" or "1^Study Deleted"
;
N MDAST,MDHOLD,MDNOTE,MDRES,MDSIEN,BODY,SUBJECT,DEVIEN
N MDHOLD,MDNOTE,MDRES,MDSIEN
S (MDHOLD,MDSIEN)=+DATA,MDRES=0,MDNOTE=""
D ALERT^MDHL7U3(MDSIEN) ; Builds the body of the mail message
I $G(^MDD(702,+MDSIEN,0))="" S @RESULTS@(0)="1^Study Deleted." D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) Q ;deleting message
S:+$P(^MDD(702,MDSIEN,0),U,6) MDNOTE=$P(^MDD(702,MDSIEN,0),U,6)
I "13"[$P(^MDD(702,MDSIEN,0),U,9) S @RESULTS@(0)="-1^Can't Delete TIU Note from a "_$$GET1^DIQ(702,MDSIEN,.09,"E")_" Study." Q
I "5"[$P(^MDD(702,MDSIEN,0),U,9) S MDCANR=$$CANCEL^MDHL7B(MDHOLD) I MDCANR<1 S @RESULTS@(0)="-1^"_$P(MDCANR,"^",2) Q
@ -36,12 +34,7 @@ DELETE ; [Procedure] Delete Study
.S @RESULTS@(0)="-1^"_$P(MDRES,"^",2)
.Q
E D
.I $D(^MDD(702.001,"ASTUDY",MDSIEN)) S @RESULTS@(0)="-1^Note associated with study, can not delete." Q
.S MDAST=$$HL7CHK^MDHL7U3(+MDSIEN) I +MDAST<1 S @RESULTS@(0)=MDAST Q
.D NOTICE^MDHL7U3(SUBJECT,.BODY,DEVIEN,DUZ) ; delete message
.S MDFDA(702,DATA_",",.01)=""
.; Check for renal study to delete as well
.S:$D(^MDK(704.202,DATA)) MDFDA(704.202,DATA_",",.01)=""
.D FILE^DIE("","MDFDA")
.N DA,DIK S DA=+MDSIEN,DIK="^MDD(702," D ^DIK
.S @RESULTS@(0)="1^Study Deleted."
@ -57,7 +50,7 @@ FILEMSG(STUDY,MDPKG,MDSTAT,MDMSG) ; [Procedure] File Study Status and Message.
FILES ; [Procedure] Add/remove an attachment to this transaction
NEW MDFDA,MDIEN,MDIENS,MDRET,P1,P2,P3,P4
S P1=$P(DATA,U,1),P2=$P(DATA,U,2),P3=$P(DATA,U,3),P4=$P(DATA,U,4)
S MDIEN=0 I $G(^MDD(702,+P1,0))="" Q
S MDIEN=0
; Look for file (All comparisons done on lower case values)
F S MDIEN=$O(^MDD(702,P1,.1,MDIEN)) Q:'MDIEN D Q:X=P3
.S X=$$LOW^XLFSTR($G(^MDD(702,P1,.1,MDIEN,.1)))
@ -98,7 +91,6 @@ GETERR ; [Procedure] Return list of Imaging Errors
NEWSTAT ; [Procedure] RPC Call to set status
S MDFDA(702,DATA,.09)=TYPE
D FILE^DIE("","MDFDA")
I TYPE=3&($G(^MDK(704.202,+DATA,0))'="") K MDFDA S MDFDA(704.202,DATA,.09)=0 D FILE^DIE("","MDFDA") K MDFDA
Q
;
RPC(RESULTS,OPTION,DATA,TYPE,FILE,RESREP) ; [Procedure] Main RPC call
@ -123,6 +115,7 @@ SUBMIT ; [Procedure] Process the Image(s) Submission.
; Create New TIU Document
S MDRESUL=$$NEWTIUN(MDSTUDY)
; File TIU Error messages
;I +MDRESUL<0 D FILEMSG(MDSTUDY,"TIU",2,MDRESUL) Q MDRESUL
I +MDRESUL<0 D Q
.D FILEMSG(MDSTUDY,"TIU",2,MDRESUL)
.S @RESULTS@(0)=MDRESUL
@ -167,7 +160,6 @@ GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note.
I MDVSTR'="" D
.S MDVSTR=$$GETVSTR^MDRPCOT1(DFN,MDVSTR,MDPROC,$$GET1^DIQ(702,MDIEN,.02,"I"))
.S MDLOC=$P(MDVSTR,";",1)
I $$GET1^DIQ(702.01,+MDPROC_",",.12,"I")=1 Q DFN_"^"_MDTITL_"^"_MDLOC_"^^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
; Does TIU doc already exist?
I $$GET1^DIQ(702,MDIEN,.06,"I") Q DFN_"^"_MDTITL_"^"_MDLOC_"^"_+$$GET1^DIQ(702,MDIEN,.06,"I")_"^"_MDCON_"^"_MDPROC_"^"_MDVSTR_"^"_MDNVST
; Does TIU doc exist for previous transaction of this consult?
@ -177,7 +169,7 @@ GETDATA(STUDY) ; [Function] Return the Necessary data for creating a TIU note.
NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction
; Input: STUDY - IENS of CP study entry
; Return: TIU Document IEN
N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP,MDPT S CTR=0,MDGST=+STUDY,MDRESU=""
N CTR,DFN,MDCON,MDFDA,MDGST,MDL,MDLOC,MDNOTE,MDPDT,MDPROC,MDRESU,MDTITL,MDTSTR,MDVST,MDVSTR,MDWP S CTR=0,MDGST=+STUDY,MDRESU=""
; Get data for TIU Note Creation
S (MDTSTR,MDRESU)=$$GETDATA(MDGST)
; File Error message
@ -191,16 +183,13 @@ NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction
I 'MDLOC Q "-1^No Hospital Location."
; Create new visit, if no vstring
S MDPDT=$$PDT^MDRPCOT1(MDGST)
I 'MDPDT S MDPT=$O(^MDD(703.1,"ASTUDYID",+MDGST,0)),MDPDT=$P($G(^MDD(703.1,+MDPT,0)),U,3)
S:'MDPDT MDPDT=$P(MDVSTR,";",2) ; If No D/T Performed grab visit D/T
I $P(MDVSTR,";",3)="V" S $P(MDVSTR,";",3)="A"
; Build variables for TIU Call
S MDWP(.05)=1 ; Undicated Status
S MDWP(1405)=+MDCON_";GMR(123," ; Package Reference
S MDWP(70201)=5 ; Default Procedure Summary Code "Machine Resulted"
I MDPDT S MDWP(70202)=MDPDT ; Date/Time Performed
; File PCE Error message
I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,$P(MDVSTR,";",2),MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2)
I MDNVST S MDRESU=$$EN1^MDPCE(MDGST,MDPDT,MDPROC,$P(MDVSTR,";",3),"P") I +MDRESU S MDVST=+MDRESU,MDVSTR=$P(MDRESU,"^",2)
I MDNVST&(+MDRESU<0) D FILEMSG(MDGST,"PCE",2,$P(MDRESU,"^",2)) Q MDRESU
; Create the TIU note stub
S MDNOTE="" D MAKE^TIUSRVP(.MDNOTE,DFN,MDTITL,$P(MDVSTR,";",2),MDLOC,$S(MDVST:MDVST,1:""),.MDWP,MDVSTR,1,1)
@ -208,9 +197,7 @@ NEWTIUN(STUDY) ; [Function] Create a new TIU for transaction
; Finalize the transaction
S MDFDA(702,STUDY_",",.06)=+MDNOTE
S MDFDA(702,STUDY_",",.08)=""
S:MDVST>0 MDFDA(702,STUDY_",",.13)=MDVST
D FILE^DIE("","MDFDA")
D UPD^MDKUTLR(STUDY,+MDNOTE)
Q 1
;
PREV(MDC,MDS) ; [Function] Return the Previous TIU document.

5
r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m
View File

@ -1,5 +1,5 @@
PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007 15:26
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 03/21/2002 ;4/11/02 15:26
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;This routine will use the HL7 Package commands to gather the message
;into the file 772
Q
@ -12,6 +12,5 @@ EN(ID) ;Entry Point
S PXRM7("PID")="HI^D"
S HLA("HLS",1)=PXRM77
D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
D STORE^PXRM7API
S ID=ZMID
Q

5
r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m
View File

@ -1,12 +1,11 @@
PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 03/21/2002 ;4/11/02 15:26
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;This is the beginning of the extraction from the extract file
;
;VARIABLE LIST
;IEN = IEN OF ENTRY IN EXTRACT FILE 810.3
Q
SPLIT ;SPLIT MESSAGES
;
N ORC2
I LINE>100 D
.S ORCCNT=ORCCNT+1

9
r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m
View File

@ -1,5 +1,5 @@
PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;09/05/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;========================================================
CDBUILD(STRING,DA) ;Given a custom date due string build the data
@ -37,10 +37,9 @@ CDUEDATE(DEFARR,FIEVAL) ;Do the custom date due calculation and return
. S TEMP=DEFARR(47,IND,0)
. S FI=$P(TEMP,U,1)
. S FREQ=$P(TEMP,U,2)
. S DATE=$S(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
. I DATE>0 S DATE=$$FULLDATE^PXRMDATE(DATE)
. S DATE=+$G(FIEVAL(FI,"DATE"))
. S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),1:0)
S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST))
S DDUE=$P(TEMP,U,1)
I DDUE=0 Q -1
S IND=$P(TEMP,U,2)

11
r/CLINICAL_REMINDERS-PXRM/PXRMCF.m
View File

@ -1,5 +1,5 @@
PXRMCF ; SLC/PKR - Handle computed findings. ;07/25/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;=======================================================
EVALFI(DFN,DEFARR,ENODE,FIEVAL) ;Evaluate computed findings.
@ -62,11 +62,10 @@ FIEVAL(FILENUM,DFN,ITEM,PFINDPA,FIEVAL) ;
;Set the finding search parameters.
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
S SDIR=$S(NOCC<0:+1,1:-1)
S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
S TEST=PFINDPA(15)
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
;Make sure NGET has the same sign as NOCC.
I NGET'=NOCC S NGET=NGET*($$ABS^XLFMTH(NOCC)/NOCC)
S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
S TEMP=^PXRMD(811.4,ITEM,0)
S TYPE=$P(TEMP,U,5)
I TYPE="" S TYPE="S"
@ -126,7 +125,7 @@ GPLIST(FILENUM,CFIEN,PFINDPA,PLIST) ;Add to the patient list
D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
S NOCCABS=$$ABS^XLFMTH(NOCC)
D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCCABS)
S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCCABS)
K ^TMP($J,TGLIST)
S ROUTINE=$P(TEMP,U,3)_"^"_$P(TEMP,U,2)_"(NGET,BDT,EDT,TGLIST,PARAM)"
D @ROUTINE

7
r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m
View File

@ -1,5 +1,5 @@
PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;============================================================
CASESEN(X,DA,FILENUM) ;
@ -78,8 +78,7 @@ SCPAR(FINDPA,CASESEN,COND,UCIFS,ICOND,VSLIST) ;Set the Condition parameters.
N CONDS
S CONDS=$G(FINDPA(3))
S COND=$P(CONDS,U,1)
;Even if there is no condition UCIFS could be used for status search.
S UCIFS=$P(CONDS,U,3)
S UCIFS=$S(COND="":0,1:$P(CONDS,U,3))
I COND="" Q
S CASESEN=$P(CONDS,U,2)
I CASESEN="" S CASESEN=1

19
r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m
View File

@ -1,5 +1,5 @@
PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;=====================================================
COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
@ -11,7 +11,7 @@ COPY(PROMPT,ROOT,WHAT) ;Copy an entry of ROOT into a new entry.
GETORGR ;Look-up logic to get and copy source entry to destination.
N DA,DIE,DIC,DIK,DIR,DIRUT,FDA,FIELDLEN,FILE
N IENN,IENO,IENS,MSG,NAME,ORGNAME,X,Y
S DIC=ROOT,DIC(0)="AEMQ",DIC("A")=PROMPT
S DIC=ROOT,DIC(0)="AEQ",DIC("A")=PROMPT
W !
D ^DIC
I $D(DUOUT)!$D(DTOUT) S DIROUT="" Q
@ -63,20 +63,11 @@ GETNAM D ^DIR
Q
;
;=====================================================
COPYLL ;Copy a location list.
N PROMPT,ROOT,WHAT
S WHAT="location list"
S ROOT="^PXRMD(810.9,"
S PROMPT="Select the reminder location list to copy: "
D COPY(PROMPT,ROOT,WHAT)
Q
;
;=====================================================
COPYREM ;Copy a reminder definition.
N PROMPT,ROOT,WHAT
S WHAT="reminder"
S ROOT="^PXD(811.9,"
S PROMPT="Select the reminder definition to copy: "
S PROMPT="Select the reminder item to copy: "
D COPY(PROMPT,ROOT,WHAT)
Q
;
@ -85,7 +76,7 @@ COPYTAX ;Copy a taxonomy.
N PROMPT,ROOT,WHAT
S WHAT="taxonomy"
S ROOT="^PXD(811.2,"
S PROMPT="Select the reminder taxonomy to copy: "
S PROMPT="Select the taxonomy item to copy: "
D COPY(PROMPT,ROOT,WHAT)
Q
;

8
r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m
View File

@ -1,5 +1,5 @@
PXRMDATA ; SLC/PKR - Routines for getting data. ;04/02/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;===============================================
GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding.
@ -12,7 +12,7 @@ GETDATA(FILENUM,DAS,FIEVT) ;Return data for a finding.
I FILENUM=70 D GETDATA^PXRMRAD(DAS,.FIEVT) Q
I FILENUM=100 D GETDATA^PXRMORDR(DAS,.FIEVT) Q
I FILENUM=120.5 D GETDATA^PXRMVITL(DAS,.FIEVT) Q
I FILENUM=601.84 D GETDATA^PXRMMH(DAS,.FIEVT) Q
I FILENUM=601.2 D GETDATA^PXRMMH(DAS,.FIEVT) Q
I FILENUM=9000010 D GETDATA^PXRMVSIT(DAS,.FIEVT,1) Q
I FILENUM=9000010.07 D GETDATA^PXRMVPOV(DAS,.FIEVT) Q
I FILENUM=9000010.11 D GETDATA^PXRMIMM(DAS,.FIEVT) Q
@ -56,6 +56,6 @@ GETFNUM(ENODE) ;Given an ENODE return the file number for the data source.
I ENODE="PSNDF(50.6," Q 52_U_55_U_"55NVA"
I ENODE="PSRX(" Q 52
I ENODE="RAMIS(71," Q 70
I ENODE="YTT(601.71," Q 601.84
I ENODE="YTT(601," Q 601.2
Q 0
;

9
r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m
View File

@ -1,5 +1,5 @@
PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;==================================================
CEFD(FDA) ;Called by the Exchange Utility only if the input packed
@ -47,10 +47,7 @@ COTN(EFP) ;Convert an Effective Period to the new date/time format.
CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
;forms as well as T-NY to a FileMan date. Also understands LAD for
;Last Admission Date.
N %DT,ND,X,Y
;Already a FileMan date?
S ND=+DATE
I (ND'<1000000),(ND'>9991231) Q DATE
N %DT,X,Y
;Check for a date FileMan understands.
S X=DATE,%DT="ST"
D ^%DT

24
r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m
View File

@ -1,11 +1,10 @@
PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;04/30/2001
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
; Called from PXRMDBL1
;
;Set number range for site
START ;
D SETSTART^PXRMCOPY("^PXRMD(801.41,")
START D SETSTART^PXRMCOPY("^PXRMD(801.41,")
;Update dialog file for individual dialog items
D UPDATE(.ARRAY,.WPTXT,"E")
;Create reminder dialog
@ -63,13 +62,15 @@ HIS(IENN) ;
MHOK(IEN) ;
N RNAME,TEST,YT S YT=""
;Convert ien to name
;DBIA #5044
S YT("CODE")=$P($G(^YTT(601.71,IEN,0)),U)
S YT("CODE")=$P($G(^YTT(601,IEN,0)),U)
;Quit if no code found
I YT("CODE")="" Q 0
I '$$OK^PXRMDLL(IEN) Q 0
;Check if this is an allowable GUI test
I (YT("CODE")'="GAF"),($P($G(^YTT(601.6,IEN,0)),U,4)'="Y") Q 0
;Get details of test
D SHOWALL^YTAPI3(.TEST,.YT)
;Check if valid
;I TEST(1)["[ERROR]" Q 0
I TEST(1)["[ERROR]" Q 0
;
S DNAME=FTYP_" "_YT("CODE")
;Create arrays
@ -81,11 +82,10 @@ MHOK(IEN) ;
I $L(DSHORT)>40 S DSHORT=$E(DNAME,1,40)
;Dialog item name, finding item and result
S ARRAY(CNT)=DSHORT_U_U_RESN_U
;Commented out Result Group Patch 6 until a decision can be made
;Result group name
;S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
S RNAME="PXRM "_YT("CODE")_" RESULT GROUP"
;Result pointer
;S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
S $P(ARRAY(CNT),U,7)=$O(^PXRMD(801.41,"B",RNAME,""))
;If aims exclude from p/n
I YT("CODE")="AIMS" S $P(ARRAY(CNT),U,6)=1
;Prompt text
@ -129,7 +129,7 @@ UPDATE(INP,WPTXT,DTYPE) ;
..S FDA(801.41,"?+1,",25)="WPTXT("_CNT_")"
..;MH fields (exclude from P/N and results pointer)
..S:$P(INP(CNT),U,6) FDA(801.41,"?+1,",54)=$P(INP(CNT),U,6)
..;S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
..S:$P(INP(CNT),U,7) FDA(801.41,"?+1,",55)=$P(INP(CNT),U,7)
.;Reminder dialog associated reminder/DISABLE
.I DTYPE="R" D
..S FDA(801.41,"?+1,",2)=REM

7
r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m
View File

@ -1,5 +1,5 @@
PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;07/28/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
;
@ -62,7 +62,6 @@ EDIT(TYP,DA,OIEN) ;
I TYP="T" S DR="[PXRM RESULT ELEMENT]"
;Allows limited edit of national dialogs
I $P($G(^PXRMD(801.41,DA,100)),U)="N" D
.I TYP="T",+$P($G(^PXMRD(801.41,DA,100)),U,4)=0 Q
.I $G(PXRMINST)=1,DUZ(0)="@" Q
.S DR="[PXRM EDIT NATIONAL DIALOG]",DINUSE=1
;
@ -275,8 +274,6 @@ LOCK(DA) ;Lock the record
I '$$VEDIT^PXRMUTIL("^PXRMD(801.41,",DA) D
.N DTYP
.S DTYP=$P($G(^PXRMD(801.41,DA,0)),U,4)
.;Allow limit edit of Result Elements that are not lock
.I DTYP="T",+$P($G(^PXRMD(801.41,DA,100)),U,4)=0 Q
.;Allow edit of findings but not component multiple on groups
.I DTYP="G",$G(PXRMDIEN),DA'=PXRMDIEN Q
.I DTYP="G",$G(PXRMGTYP)="DLGE" Q

6
r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m
View File

@ -1,5 +1,5 @@
PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;01/24/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;==================================================
CMOUT ;Do formatted Clinical Maintenance output.
@ -31,6 +31,7 @@ DEB ;Prompt for patient and reminder by name input component.
S DFN=+$P(Y,U,1)
I DFN=-1 W !,"No patient selected!" Q
S DIC=811.9,DIC("A")="Select Reminder: "
S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q
@ -66,6 +67,7 @@ DEV ;Prompt for patient and reminder by name and evaluation date.
I $D(DTOUT)!$D(DUOUT) Q
S DFN=+$P(Y,U,1)
S DIC=811.9,DIC("A")="Select Reminder: "
S DIC("S")="I $P(^PXD(811.9,Y,100),U,4)'[""L"""
D ^DIC
I $D(DIROUT)!$D(DIRUT) Q
I $D(DTOUT)!$D(DUOUT) Q

20
r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m
View File

@ -1,5 +1,5 @@
PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;10/31/2005
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text
N DIWF,DIWL,DIWR,IC,TEXT,X,TXTCNT,DTXT,CNT,SUB2
@ -21,8 +21,10 @@ ADD ;PXRM DIALOG ADD ELEMENT validation
N ANS,DTOUT,DUOUT,LIT,LOCK,Y,PIEN,ERR,IEN,NATIONAL,SEQ
W IORESET
S VALMBCK="R",NATIONAL=0
;Check if national reminder dialog
I $P($G(^PXRMD(801.41,PXRMDIEN,100)),U)="N" S NATIONAL=1
S LOCK=$P($G(^PXRMD(801.41,PXRMDIEN,100)),U,4)
;Dissallow editing of national dialogs
I NATIONAL,'($G(PXRMINST)=1)&(DUZ(0)="@"),$G(LOCK)'=1 D Q
.W !,"Elements may not be added to national reminder dialogs" H 2
;
@ -60,6 +62,7 @@ DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components
.S DSUB=$O(^PXRMD(801.41,DIEN,10,"B",DSEQ,"")) Q:'DSUB
.;Get ien of prompt/component
.S DCIEN=$P($G(^PXRMD(801.41,DIEN,10,DSUB,0)),U,2) Q:'DCIEN
.;Ignore prompts and forced values
.I "PF"[$P($G(^PXRMD(801.41,DCIEN,0)),U,4) Q
.;Save line in workfile
.D DLINE(DCIEN,LEV,DSEQ,NODE)
@ -73,7 +76,7 @@ DETAIL(DIEN,LEV,VIEW,NODE) ;;Build listman global for all components
;
DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
N CNT,DBOX,DCAP,DDIS,DMULT,DSUPP,DSHOW,DTYP,DTXT
N IC,RESNM,RESULT,RIEN,RNAME,RCNT
N IC,RESNM,RESULT,RIEN,RNAME
;Dialog name
S DDATA=$G(^PXRMD(801.41,DIEN,0)),DNAM=$P(DDATA,U) Q:DNAM=""
;Check if standard PXRM prompt
@ -85,6 +88,9 @@ DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
;Resolution type and name
S RNAME="",RIEN=$P($G(^PXRMD(801.41,DIEN,1)),U,3)
I RIEN S RNAME=$P($G(^PXRMD(801.9,RIEN,0)),U)
;Result Group
S RESULT=$P(DDATA,U,15)
I RESULT S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U)
;
;Group fields
I DTYP="Group" D
@ -141,13 +147,6 @@ DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
.I RNAME]"" D
..S TEMP=$J("",TAB)_"Resolution: "_RNAME
..S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
.;Result Group
.I VIEW=4 D
..S RCNT=0 F S RCNT=$O(^PXRMD(801.41,DIEN,51,RCNT)) Q:RCNT'>0 D
...S RESULT=$P($G(^PXRMD(801.41,DIEN,51,RCNT,0)),U)
...S RESNM=$P($G(^PXRMD(801.41,RESULT,0)),U) Q:RESNM=""
...S TEMP=$J("",TAB)_"Result Group: "_RESNM
...S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=TEMP
.;Additional findings
.D FADD(DIEN,TAB)
;Get additional prompts
@ -165,6 +164,7 @@ DLINE(DIEN,LEV,DSEQ,NODE) ;Save individual component details
;
FDESC(FIEN) ;Finding description
N FGLOB,FITEM,FNUM
;Determine finding type
S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
S FITEM=$P(FIEN,";") Q:FITEM=""
S FNUM=" ["_FITEM_"]"

204
r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m
View File

@ -1,20 +1,6 @@
PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
;Display branching logic text in dialog summary view
N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
S DATA=$G(^PXRMD(801.41,DIEN,49))
I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
I +$P(DATA,U,3)>0 D
.S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
.S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
Q
;
ASK(YESNO,PIEN) ;Confirm
K DIR,DIROUT,DIRUT,DNAME,DTOUT,DTYP,DUOUT,TEXT,X,Y
@ -36,6 +22,46 @@ ASK(YESNO,PIEN) ;Confirm
S VALMBCK="R"
Q
;
MSEL(NUM) ;
I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
Q 1
;
ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
;Display branching logic text in dialog summary view
N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
S DATA=$G(^PXRMD(801.41,DIEN,49))
I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
I +$P(DATA,U,3)>0 D
.S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
.S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
Q
;
OTERM(DA) ;
K OTERM
S OTERM=$P($G(^PXRMD(801.41,DA,49)),U) Q
;
NTERM(DA,OTERM,NTERM) ;
I +OTERM=0 S OTERM=$P($G(DA),U)
I +NTERM=0 K OTERM Q 2
I +OTERM=0,+NTERM>0 K OTERM Q 1
I +OTERM'=+NTERM K OTERM Q 0
K OTERM
Q 1
;
TERMS(DA,X) ;
N TERM
S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
I +TERM=0 D Q 0
.W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
.H 2
I +TERM>0,$G(X)="" Q 2
Q 1
;
BHELP(VALUE) ;
N HTEXT
D FULL^VALM1
@ -64,7 +90,16 @@ BHELP(VALUE) ;
D HELP^PXRMEUT(.HTEXT)
Q
;
TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
N CNT1,NOUT,OUTPUT,WIDHT
S WIDTH=IOM-(2+(CNT+ATLEN))
S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
I NOUT>0 F CNT1=1:1:NOUT D
.S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
Q
;
INQ(DIEN) ;INQ Inquiry/Print option
;
; Used by 801.41 print templates
; [PXRM REMINDER DIALOG]
; [PXRM DIALOG GROUP]
@ -83,140 +118,3 @@ INQ(DIEN) ;INQ Inquiry/Print option
F S SUB=$O(^TMP(NODE,$J,SUB)) Q:'SUB W !,^TMP(NODE,$J,SUB,0)
K ^TMP(NODE,$J)
Q
;
MH(IEN) ;Allow IEN=109 (HX2) as a place holder for 601 entries that do not
;have a corresponding 601.71 entry.
I IEN=109 Q 1
I $G(PXRMINST)=1 Q 1
N MAXNUM
S MAXNUM=+$P($G(^PXRM(800,1,"MH")),U)
I MAXNUM=0 S MAXNUM=25
Q $$ONECR^YTQPXRM5(IEN,MAXNUM)
;
MHLICR(IEN) ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
;branching works.
N Y
;DBIA #5042
I $$RL^YTQPXRM3(IEN)="Y" D
.W !,"This MH test requires a license."
.W !,"The question text will not appear in the progress note.",!
.H 1
Q
;
MSEL(NUM) ;
I NUM=4,'$$PATCH^XPDUTL("OR*3.0*243") D EN^DDIOL("THIS SELECTION IS NOT VALID, UNTIL CPRS 27 IS INSTALLED") Q 0
Q 1
;
MHREQHLP ;
N TEXT
S TEXT(1)="Select 0, ""Optional open and optional complete (partial complete possible)"","
S TEXT(2)="if the user should be able to optionally select/open the MH test in the reminder dialog and optionally complete the MH test before the reminder dialog can be finished."
S TEXT(3)=" "
S TEXT(4)="Select 1, ""Required open and required complete before finish"","
S TEXT(5)="if the user is required to select/open and complete the MH test in the reminder dialog before the reminder dialog can be finished."
S TEXT(6)=" "
S TEXT(7)="Select 2, ""Optional open and required complete or cancel before finish"","
S TEXT(8)="if the user should be able to optionally select/open the MH test in the reminder dialog; however, if the user opens the MH test, then the user is required to complete or cancel the MH test before the reminder dialog can be finished."
S TEXT(9)=" "
S TEXT(10)="Note: Clicking the cancel button in the MH Test is considered the same as not opening the MH Test."
S TEXT(11)="Also, Option 2, ""Optional open and required complete or cancel before finish"", only works with CPRS 27 and"
S TEXT(12)="YS_MHA.dll. If Option 2 is selected and the user is using a pre-CPRS 27 version this option will be treated by CPRS as Option 1, ""Required open and required complete before finish""."
D HELP^PXRMEUT(.TEXT)
Q
;
NTERM(DA,OTERM,NTERM) ;
I +OTERM=0 S OTERM=$P($G(DA),U)
I +NTERM=0 K OTERM Q 2
I +OTERM=0,+NTERM>0 K OTERM Q 1
I +OTERM'=+NTERM K OTERM Q 0
K OTERM
Q 1
;
OTERM(DA) ;
K OTERM
S OTERM=$P($G(^PXRMD(801.41,DA,49)),U)
Q
;
RESCHK(IEN) ;Called by input template PXRM EDIT ELEMENT. Preserve Y so template
;branching works.
N CNT,FDA,MSG,RG,RGIEN,VALID,Y
S CNT=0
F S CNT=$O(^PXRMD(801.41,IEN,51,CNT)) Q:CNT'>0 D
.S RGIEN=$P($G(^PXRMD(801.41,IEN,51,CNT,0)),U) I +RGIEN'>0 Q
.S RG=$P($G(^PXRMD(801.41,RGIEN,0)),U,1)
.I RG="" Q
.S VALID=$$RGLSCR(IEN,RG,RGIEN)
.I VALID Q
.W !,"Deleting the result group ",RG," from the element/group."
.S FDA(801.41121,CNT_","_IEN_",",.01)="@"
.D FILE^DIE("E","FDA","MSG")
.S RGKILL=1
.I $D(MSG) D AWRITE^PXRMUTIL("MSG")
Q
;
RSELEDIT(DA) ;
N NODE,RESULT
;RESULT=0 EDIT NOTHING
;RESULT=1 EDIT INFORMATIONAL TEXT
;RESULT=2 EDIT EVERYTHING
S RESULT=2
I $G(PXRMINST)=1,DUZ(0)="@" Q RESULT
S NODE=$G(^PXRMD(801.41,DA,100))
I $P(NODE,U)="N" S RESULT=0
I RESULT=0,+$P(NODE,U,4)=0 S RESULT=1
Q RESULT
;
RGLSCR(DA,X,IEN) ;Input transform/screen for RESULT GROUP LIST
I $G(PXRMINST)=1 Q 1
I $G(PXRMEXCH)=1 Q 1
N HELP,MHTEST,TEXT,VALID,Y
S NMATCH=0
S MHTEST=$O(^PXRMD(801.41,"B",X),-1)
F S MHTEST=$O(^PXRMD(801.41,"B",MHTEST)) Q:(NMATCH>1)!(MHTEST'[X) S NMATCH=NMATCH+1
;If there is an exact match to the user's input turn help on.
S HELP=$S($G(DIQUIET):0,NMATCH=1:1,1:0)
S VALID=1
;Make sure the TYPE is a result group
I '$D(^PXRMD(801.41,"TYPE","S",IEN)) D
. I HELP S TEXT(1)="TYPE must be a result group."
. S VALID=0
;Make sure the finding item for the element matches the
;MH Test assigned to the Result Group
S MHTEST=+$P($G(^PXRMD(801.41,DA,1)),U,5) I MHTEST="" D
. I HELP S TEXT(2)="The MH test is missing."
. S VALID=0
I +$P($G(^PXRMD(801.41,IEN,50)),U)'=MHTEST D
. I HELP S TEXT(3)="The finding item does not match the MH Test assigned to the Result Group"
. S VALID=0
;Make sure a scale has been defined.
I +$P($G(^PXRMD(801.41,IEN,50)),U,2)'>0 D
. I HELP S TEXT(4)="An MH Scale must be defined."
. S VALID=0
;Make sure it is not disabled.
I $P($G(^PXRMD(801.41,IEN,0)),U,3)'="" D
. S VALID=0
. I HELP D
.. N EM,TYPE
.. S TYPE=$P(^PXRMD(801.41,IEN,0),U,4)
.. S TYPE=$$EXTERNAL^DILFD(801.41,4,"",TYPE,.EM)
.. S TEXT(5)="The "_TYPE_" is disabled."
I HELP,'VALID D EN^DDIOL(.TEXT)
Q VALID
;
TERMS(DA,X) ;
N TERM
S TERM=$P($G(^PXRMD(801.41,DA,49)),U)
I +TERM=0 D Q 0
.W !,"Cannot set Reminder Term Status if the Reminder Term field is blank"
.H 2
I +TERM>0,$G(X)="" Q 2
Q 1
;
TEXT(NLINES,CNT,ATLEN,TEMP,NODE) ;
N CNT1,NOUT,OUTPUT,WIDHT
S WIDTH=IOM-(2+(CNT+ATLEN))
S CNT1=1 D FORMATS^PXRMTEXT(1,WIDTH,TEMP,.NOUT,.OUTPUT)
I NOUT>0 F CNT1=1:1:NOUT D
.S NLINE=NLINE+1,^TMP(NODE,$J,NLINE,0)=$J("",2+(CNT+ATLEN))_OUTPUT(CNT1)
Q
;

12
r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m
View File

@ -1,5 +1,5 @@
PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;01/11/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;05/31/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;Called by option PXRM DIALOG/COMPONENT EDIT
;
@ -228,7 +228,11 @@ XINP(X) ;Taxonomy findings are not allowed for dialog groups
I $P(X,";",2)="PXD(811.2,",$P($G(^PXRMD(801.41,DA,0)),U,4)="G" D Q 0
.W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
;Only applies to MH
I $P(X,";",2)'="^YTT(601.71," Q 1
I $$OK^PXRMDLL($P(X,";")) Q 1
I $P(X,";",2)'="YTT(601," Q 1
;GAF
I $P($G(^YTT(601,$P(X,";"),0)),U)="GAF" Q 1
;Check if a VALID GUI test
I $P($G(^YTT(601.6,$P(X,";"),0)),U,4)="Y" Q 1
;else
W *7,!,"This test is not appropriate for the GUI",!
Q 0

18
r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m
View File

@ -1,9 +1,11 @@
PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
;;2.0;CLINICAL REMINDERS;**10,6**;Feb 04, 2005;Build 123
;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
;
OK(DIEN) ;Check if mental health test is for GUI
I 'DIEN Q 0
Q $$MH^PXRMDLG5(DIEN)
I 'DFIEN Q 0
I $P($G(^YTT(601.6,DFIEN,0)),U,4)="Y" Q 1
I $P($G(^YTT(601,DFIEN,0)),U)="GAF" Q 1
Q 0
;
TXT ;Format text
N NULL
@ -99,9 +101,7 @@ GROUP(DIEN,DSUB) ;Dialog group
.;If the actual element is exclude from P/N override
.I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
.S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
.S DMHEX=$P(DATA,U,14)
.S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)
.;S DRESL=$P(DATA,U,15)
.S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
.S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
.;Done Elsewhere (historical)
.S DHIS=$$AHIS(DGIEN)
@ -145,7 +145,7 @@ LOAD(DIEN,DFN) ;Load dialog questions into array
S DARRAY("AUTTSK(")="SK"
S DARRAY("GMRD(120.51,")="VIT"
S DARRAY("ORD(101.41,")="Q"
S DARRAY("YTT(601.71,")="MH"
S DARRAY("YTT(601,")="MH"
S DARRAY("ICD9(")="POV"
S DARRAY("ICPT(")="CPT"
S DARRAY("PXD(811.2,")="T"
@ -167,9 +167,7 @@ LOAD(DIEN,DFN) ;Load dialog questions into array
..S TERMSTAT=1
..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
.S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
.S DMHEX=$P(DATA,U,14)
.S DRESL=$$RESGROUP^PXRMDLLB(DITEM)
.;S DRESL=$P(DATA,U,15)
.S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
.K DTXT S SUB=0
.F S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB D
..S DTXT(SUB)=$G(^PXRMD(801.41,DITEM,25,SUB,0))

12
r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m
View File

@ -1,5 +1,5 @@
PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
FREC(DFIEN,DFTYP) ;Build type 3 record
N CSARRAY,CSCNT
@ -24,11 +24,9 @@ FREC(DFIEN,DFTYP) ;Build type 3 record
.S:DPCE="Q" $P(ORY(OCNT),U,11)=$P($G(^ORD(101.41,DFIEN,0)),U,4)
.;If mental health check if a GAF score and if MH test is required
.I DPCE="MH",DFIEN D
..;DBIA #5044
..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
..I $P($G(^YTT(601,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
..;Check to see if the MH test is required
..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
..S $P(ORY(OCNT),U,13)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0)
Q
;
GUI(IEN) ;Work out prompt type for PCE
@ -51,7 +49,7 @@ LOAD(DITEM,DCUR,DTTYP) ;Load dialog questions into array
;
S DARRAY("GMRD(120.51,")="VIT"
S DARRAY("ORD(101.41,")="Q"
S DARRAY("YTT(601.71,")="MH"
S DARRAY("YTT(601,")="MH"
;
S DARRAY("ICD9(")="POV"
S DARRAY("ICPT(")="CPT"

16
r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m
View File

@ -1,5 +1,5 @@
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
CODE(DFIEN,DFTYP,ARRAY) ;
N ARY,CNT,CNT1
@ -107,18 +107,6 @@ REPLACE(DFN,TERMNODE,DITEM,DATA,TERMSTAT) ;
.I $G(DATA)=""!($P(DATA,U,3)]"") S DITEM=DITEMO Q
Q
;
RESGROUP(DIEN) ;
N CNT,RESULT,TEMP
S RESULT=""
I $$PATCH^XPDUTL("OR*3.0*243")=0 D Q RESULT
.S RESULT=$P($G(^PXRMD(801.41,DIEN,51,1,0)),U) I RESULT="" Q
.I $P($G(^PXRMD(801.41,RESULT,0)),U,3)'="" S RESULT="" Q
S CNT=0 F S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0 D
.S TEMP=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) I TEMP="" Q
.I $P($G(^PXRMD(801.41,TEMP,0)),U,3)'="" S TEMP="" Q
.S RESULT=$S(RESULT="":TEMP,1:RESULT_"~"_TEMP)
Q RESULT
;
TERM(TERMIEN,DFN,IEN) ;
;this section is use to for the term evaluation
N ARRAY,CNT,NODE,RESULT,TERMARR

33
r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m
View File

@ -1,32 +1,24 @@
PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;06/09/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;Build score related P/N text from score and result group
;
;If not found
START(ORY,RESULT,ORES) ;
I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
;
N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT
;
I RESULT["~" S RESULT=$P(RESULT,"~")
S ERROR=0
;
;Get score using API
K ^TMP($J,"YSCOR")
S DFN=$G(ORES("DFN"))
I ORES("CODE")'="DOM80" D Q:ERROR
.M YT=ORES
.F X=1:1:$L(YT("R1")) I $E(YT("R1"),X)'="X" S YT(X)=X_U_$E(YT("R1"),X)
.K YT("R1")
.D CHECKCR^YTQPXRM4(.ARRAY,.YT)
.S OK=0
.;D PREVIEW^YTAPI4(.ARRAY,.YT)
.I ^TMP($J,"YSCOR",1)'="[DATA]" S ORY(1)="-1^"_^TMP($J,"YSCOR",1)_^TMP($J,"YSCOD",2),ERROR=1 Q
.;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
.I $P($G(^TMP($J,"YSCOR",2)),"=",2)'="" S SCORE=$P($G(^TMP($J,"YSCOR",2)),"=",2),OK=1
.;S SUB=0,OK=0
.;F S SUB=$O(ARRAY(SUB)) Q:'SUB D Q:OK
.;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
.D PREVIEW^YTAPI4(.ARRAY,.YT)
.I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
.S SUB=0,OK=0
.F S SUB=$O(ARRAY(SUB)) Q:'SUB D Q:OK
..I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
.I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
;
;Except for DOM80
@ -35,7 +27,6 @@ START(ORY,RESULT,ORES) ;
.I $E(ORES("R1"),2,3)="YY",($E(ORES("R1"),4)>1) S SCORE=1 Q
.S SCORE=0
;
S DFN=$G(ORES("DFN"))
S INSERT("SCORE")=SCORE
;
;For AIMS special formatting is required
@ -48,8 +39,6 @@ START(ORY,RESULT,ORES) ;
..I (CNT<8),(234[RESP) S SUM(RESP)=SUM(RESP)+1
.F CNT=2,3,4 S INSERT("SUM"_CNT)=SUM(CNT)
;
TEXT ;
I RESULT["~" S RESULT=$P(RESULT,"~")
;Load dialog results into ORY array
N DATA,DCON,DITEM,DSEQ,DSUB,DTYP,INS,SEP,TEXT
;Get the result elements
@ -82,10 +71,6 @@ TEXT ;
..S OCNT=OCNT+1,ORY(OCNT)=7_U_TEXT
Q
;
MHDLL(ORES,RESULT,SCORE,DFN) ;
S INSERT("SCORE")=SCORE
D TEXT
Q
OUT(DATA) ;Display element details
N DITEM S DITEM=$P(DATA,U,2) Q:'DITEM
W $P($G(^PXRMD(801.41,DITEM,0)),U)

12
r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m
View File

@ -1,5 +1,5 @@
PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 02/04/2004
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;=======================================================================
START(NUM) ;
@ -41,7 +41,7 @@ EN1 ;
. I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
. W !," "_$G(NAME) S PCNT=PCNT+1 I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
I FOUND=0 W !,"No empty dialog found"
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
I ($E(IOST)="C")&(IO=IO(0)) D
. W !
. S DIR(0)="E" D ^DIR K DIR
Q
@ -65,7 +65,7 @@ OUTPUT ;
. .W !,$$LJ^XLFSTR("",4)_NAME S PCNT=PCNT+1
. .I (PCNT+1)'<IOSL D PAGE(.PCNT,.PAGE) I $G(DONE)=1 Q
K ^TMP("PXRMDLR1",$J)
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
I ($E(IOST)="C")&(IO=IO(0)) D
. W !
. S DIR(0)="E" D ^DIR K DIR
Q
@ -78,12 +78,12 @@ HEADER(PCNT,PAGE,TITLE) ;
;
PAGE(PCNT,PAGE) ;
N DUOUT,DTOUT,DIROUT,DIR
I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
I ($E(IOST)="C")&(IO=IO(0)) D
.S DIR(0)="E"
.W !
.D ^DIR K DIR
I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S DONE=1 Q
W:$D(IOF) @IOF
S PAGE=PAGE+1,PCNT=0
I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF D HEADER(.PCNT,PAGE,TITLE)
I $E(IOST)="C",IO=IO(0) W @IOF D HEADER(.PCNT,PAGE,TITLE)
Q

9
r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m
View File

@ -1,5 +1,5 @@
PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;03/14/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;05/24/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;===============================================
GETDATA(DAS,FIEVT) ;Return data for an non-VA med finding.
@ -17,11 +17,10 @@ EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate terms.
;
;====================================================
MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
N DATE,JND,NOUT,TEMP,TEXTOUT
N JND,NOUT,TEMP,TEXTOUT
S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
S DATE=IFIEVAL("DISCONTINUED DATE")
S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
S TEMP=TEMP_" - "_$$EDATE^PXRMDATE(IFIEVAL("STOP DATE"))_")"
D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
Q

17
r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m
View File

@ -1,5 +1,5 @@
PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/20/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/12/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;Groups are drug classes or VA Generic.
;==================================================
EVALFI(DFN,DEFARR,ENODE,XREF,FIEVAL) ;Evaluate drug group findings.
@ -99,8 +99,6 @@ FIEVAL(DFN,DRGRIEN,FINDPA,DEFARR,FINDING,XREF,FIEVAL) ;
. I FIEVT D
.. S IND=0
.. F S IND=+$O(FIEVT(IND)) Q:IND=0 D
...;Make sure this is not already on the list
... I $$ONLIST(.FIEVTL,IND,.FIEVT) Q
... S NFOUND=NFOUND+1,FIEVTL(NFOUND,"DISPENSE DRUG")=DRUGIEN
... M FIEVTL(NFOUND)=FIEVT(IND)
... S DATEORDR(FIEVT(IND,"DATE"),NFOUND)=FIEVT(IND,"FINDING")
@ -184,14 +182,3 @@ GPLIST(DRGRIEN,PFINDPA,XREF,PLIST) ;
K ^TMP($J,TGLIST)
Q
;
;==================================================
ONLIST(FIEVTL,IND,FIEVT) ;Return true if FIEVT(IND) is already on
;FIEVTL.
N JND,ONLIST
S (JND,ONLIST)=0
F S JND=$O(FIEVTL(JND)) Q:(ONLIST)!(JND="") D
. I FIEVTL(JND,"FILE NUMBER")'=FIEVT(IND,"FILE NUMBER") Q
. I FIEVTL(JND,"DAS")'=FIEVT(IND,"DAS") Q
. S ONLIST=1
Q ONLIST
;

10
r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m
View File

@ -1,5 +1,5 @@
PXRMDRUG ; SLC/PKR - Handle drug findings. ;04/23/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;===============================================
DEVAL(DFN,FINDPA,DEFARR,FINDING,RXTYL,DRUG,POI,FIEVAL) ;Evaluate a drug
@ -113,7 +113,7 @@ EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;Evaluate drug terms for
;
;===============================================
EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms.
N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,JND,NOINDEX,PFINDPA,POI
N DATEORDR,DRUGIEN,DTERM,DTFIEVAL,IND,NOINDEX,PFINDPA,POI
N RXTYL,TEMP,TFINDING,TFINDPA
N DATEORDR,NOCC,SDIR
S NOINDEX=0
@ -158,9 +158,7 @@ EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate drug terms.
.. D IEVALTER^PXRMTERM(DFN,.PFINDPA,.DTERM,TFINDING,.DTFIEVAL)
.. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
.. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
..;Save the dispense drug
.. S JND=0
.. F S JND=+$O(TFIEVAL(TFINDING,JND)) Q:JND=0 S TFIEVAL(TFINDING,JND,"DISPENSE DRUG")=DRUGIEN
.. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN
Q
;
;===============================================

9
r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m
View File

@ -1,17 +1,14 @@
PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007
;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;05/18/2000
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
EDIT(ROOT,IENN) ;Call the appropriate edit routine.
;Reminder location list
I ROOT="^PXRMD(810.9," D EDIT^PXRMLLED(ROOT,IENN) Q
;
;Taxonomy
I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
;
;Reminder term
I ROOT="^PXRMD(811.5," D EDIT^PXRMTMED(ROOT,IENN) Q
;
;Reminder definition
;Reminder
I ROOT="^PXD(811.9," D
.;Build list of finding types for finding edit
. N DEF,DEF1,DEF2 D DEF^PXRMRUTL("811.902",.DEF,.DEF1,.DEF2)

11
r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m
View File

@ -1,5 +1,5 @@
PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;========================================================
KENODE(X,DA,FILENUM) ;Kill the enode in the finding multiple for definitions
@ -29,7 +29,7 @@ SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions
;and terms.
;Do not execute as part of a verify fields.
I $G(DIUTIL)="VERIFY FIELDS" Q
N DAS,GLOBAL,IEN,NAME
N DAS,GLOBAL,IEN
S IEN=$P(X,";",1)
S GLOBAL=$P(X,";",2)
I GLOBAL="LAB(60," D
@ -43,8 +43,7 @@ SENODE(X,DA,FILENUM) ;Set the enode in the finding multiple for definitions
. S IEN="A;T;"_IEN
S DAS=IEN
I DAS="" Q
S NAME=""
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=""
I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=""
Q
;

18
r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m
View File

@ -1,5 +1,5 @@
PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;07/17/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;06/21/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;Main entry point for PXRM EXTRACT DEFINITIONS
START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
@ -12,7 +12,11 @@ START N PXRMDONE,VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
BLDLIST ;Build workfile
K ^TMP("PXRMEPM",$J)
N IEN,IND,PLIST
D LIST^PXRMETM("PXRMEPM",.VALMCNT)
D LIST^PXRMETM(.PLIST,.IEN)
M ^TMP("PXRMEPM",$J)=PLIST
S VALMCNT=PLIST("VALMCNT")
F IND=1:1:VALMCNT D
.S ^TMP("PXRMEPM",$J,"IDX",IND,IND)=IEN(IND)
Q
;
ENTRY ;Entry code
@ -60,12 +64,12 @@ XSEL ;PXRM EXTRACT DEFINITION SELECT ENTRY validation
I SEL["," D Q
.W $C(7),!,"Only one item number allowed." H 2
.S VALMBCK="R"
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
;
;Get the list ien.
S IEN=^TMP("PXRMEPM",$J,"SEL",SEL)
S IEN=^TMP("PXRMEPM",$J,"IDX",SEL,SEL)
;Display/Edit Extract Definition
D START^PXRMEPED(IEN)
D BLDLIST
@ -81,6 +85,7 @@ HELP(CALL) ;General help text routine
Q
;
EPADD ;Add Rule Option
;
;Reset Screen Mode
W IORESET
;
@ -89,6 +94,7 @@ EPADD ;Add Rule Option
;
;Rebuild Workfile
D BLDLIST
;
S VALMBCK="R"
Q
;
@ -102,7 +108,7 @@ EPINQ ;Definition Inquiry - PXRM EXTRACT DEFINITION DISPLAY/EDIT entry
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the ien.
.S LRIEN=^TMP("PXRMEPM",$J,"SEL",IND)
.S LRIEN=^TMP("PXRMEPM",$J,"IDX",IND,IND)
.D START^PXRMEPED(LRIEN)
D BLDLIST
S VALMBCK="R"

15
r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m
View File

@ -1,5 +1,5 @@
PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005
;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
;
;
ADHOC(IEN,PXRMSTRT,PXRMSTOP) ;Ad Hoc Conformance Report
@ -32,7 +32,7 @@ REPORT ;Initialise
;Bookmark - Needs inventive patient list names
S LIST=NAME_" REPORT "_DATES
;Process (single) Denominator rule into patient list
N INDP,INTP,SEQ,SUB,SUFFIX
N SEQ,SUB,SUFFIX
S SEQ=""
F S SEQ=$O(^PXRM(810.2,IEN,10,"B",SEQ)) Q:'SEQ D
.S SUB=$O(^PXRM(810.2,IEN,10,"B",SEQ,"")) Q:'SUB
@ -40,11 +40,9 @@ REPORT ;Initialise
.S PXRMRULE=$P(DATA,U,2) Q:'PXRMRULE
.S SUFFIX=$P(DATA,U,3)
.I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
.S INDP=+$P(DATA,U,4)
.S INTP=+$P(DATA,U,5)
.;Create new patient list
.S PXRMLIST=$$CRLST^PXRMRUL1(LIST_" "_SUFFIX) Q:'PXRMLIST
.D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,INDP,INTP)
.S PXRMLIST=$$CRLST^PXRMRULE(LIST_" "_SUFFIX) Q:'PXRMLIST
.D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,"","")
.;Clear ^TMP lists created for rule
.D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
.;Process reminders
@ -119,8 +117,7 @@ QUE ;BOOKMARK - NOT USED
S MINDT=$$NOW^XLFDT
W !,"Queue the Clinical Reminders MST synchronization."
S DIR("A",1)="Enter the date and time you want the job to start."
S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
S DIR("A")="Start the task at: "
S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
S DIR(0)="DAU"_U_MINDT_"::RSX"
D ^DIR
I $D(DTOUT)!$D(DUOUT) Q

284
r/CLINICAL_REMINDERS-PXRM/PXRMETH.m
View File

@ -1,13 +1,12 @@
PXRMETH ; SLC/PJH - Reminder Extract History ;10/11/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
PXRMETH ; SLC/PJH - Reminder Extract History ;08/15/2006
;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
;
;Main entry point for PXRM EXTRACT HISTORY
START(EDIEN) ;
;EDIEN is the extract definition IEN.
START(IEN) ;
N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
;Details of last run
N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
S DATA=$G(^PXRM(810.2,EDIEN,0))
S DATA=$G(^PXRM(810.2,IEN,0))
S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
;Default view is in date created order
S PXRMVIEW="D"
@ -17,20 +16,8 @@ START(EDIEN) ;
D EN^VALM("PXRM EXTRACT HISTORY")
Q
;
DELETE ;Delete an extract, called by protocol PXRM EXTRACT SUMMARY DELETE.
N CLASS,IEN,IENLIST,IND
S IENLIST=$$LMSEL
F IND=1:1:$L(IENLIST,U) D
.S IEN=$P(IENLIST,U,IND)
.D DELETE^PXRMETXU(IEN)
;Rebuild workfile
D BLDLIST^PXRMETH1(EDIEN)
;Refresh
S VALMBCK="R"
Q
;
ENTRY ;Entry code
D BLDLIST^PXRMETH1(EDIEN),XQORM
D BLDLIST^PXRMETH1(IEN),XQORM
Q
;
EXIT ;Exit code
@ -41,7 +28,90 @@ EXIT ;Exit code
S VALMBCK="Q"
Q
;
EXTRACT(EDIEN) ;Run Extract/Transmission
HDR ; Header code
N VIEW
S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
S VALMHDR(2)=" Extract Name: "_$P($G(^PXRM(810.2,IEN,0)),U)
S VALMHDR(3)=" Next Extract Period: "_NPERIOD
S VALMHDR(4)=" Scheduled to Run: "_NSDATE
S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_" View: "_VIEW
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HLP ;Help code
N ORU,ORUPRMT,SUB,XQORM
S SUB="PXRMETHH"
D EN^VALM("PXRM EXTRACT HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
PEXIT ;PXRM EXCH MENU protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
D XQORM
Q
;
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
Q
;
XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
N SEL,PXRMSIEN
S SEL=$P(XQORNOD(0),"=",2)
;Remove trailing ,
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
;Invalid selection
I SEL["," D Q
.W $C(7),!,"Only one item number allowed." H 2
.S VALMBCK="R"
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("IDX",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
;
;Get the list ien.
S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
;
;Full screen mode
D FULL^VALM1
;
;Options
N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="SBM"_U_"ES:Extract Summary;"
S DIR(0)=DIR(0)_"MT:Manual Transmission;"
S DIR(0)=DIR(0)_"TH:Transmission History;"
S DIR("A")="Select Action"
S DIR("B")="ES"
S DIR("?")="Select from the codes displayed. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMETH1(1)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
S OPTION=Y
;
;Display Extract Summary
I OPTION="ES" D
.D START^PXRMETT(PXRMSIEN)
;
;Transmission option
I OPTION="MT" D
.N ANS,DUOUT,DTOUT,RTN,TEXT
.I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D Q
..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
.I ANS D TRANS^PXRMETX(PXRMSIEN)
;
;Transmission History
I OPTION="TH" D
.D START^PXRMETHL(PXRMSIEN)
;
S VALMBCK="R"
Q
;
EXTRACT(IEN) ;Run Extract/Transmission
;
;Reset screen mode
W IORESET
;Refresh on exit
@ -50,8 +120,8 @@ EXTRACT(EDIEN) ;Run Extract/Transmission
;Get details from parameter file
N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
S DATA=$G(^PXRM(810.2,EDIEN,0))
S NAT=$P($G(^PXRM(810.2,EDIEN,100)),U)
S DATA=$G(^PXRM(810.2,IEN,0))
S NAT=$P($G(^PXRM(810.2,IEN,100)),U)
;Determine Extract Name and Frequency
S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
;Save next scheduled extract
@ -92,8 +162,8 @@ PLIST ;
;Extract/transmission run
N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
S ZTDESC="Reminder Extract "_NAME
S ZTRTN="RUN^PXRMETX(EDIEN,NEXT,MODE,EXSUMPUG)"
S ZTSAVE("EDIEN")=""
S ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)"
S ZTSAVE("IEN")=""
S ZTSAVE("MODE")=""
S ZTSAVE("NEXT")=""
S ZTSAVE("PLISTPUG")=""
@ -116,48 +186,12 @@ PLIST ;
S ZTDTH=SDTIME
D ^%ZTLOAD
W !,"Task number ",ZTSK," queued." H 2
;
S VALMBCK="Q"
Q
;
HDR ; Header code
N VIEW
S VIEW=$S(PXRMVIEW="D":"Creation Date Order",1:"Extract Period Order")
S VALMHDR(2)=" Extract Name: "_$P($G(^PXRM(810.2,EDIEN,0)),U)
S VALMHDR(3)=" Next Extract Period: "_NPERIOD
S VALMHDR(4)=" Scheduled to Run: "_$$FMTE^XLFDT(NSDATE,"5Z")
S VALMHDR(4)=$$LJ^XLFSTR(VALMHDR(4),45)_" View: "_VIEW
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
Q
;
HLP ;Help code
N ORU,ORUPRMT,SUB,XQORM
S SUB="PXRMETHH"
D EN^VALM("PXRM EXTRACT HELP")
Q
;
INIT ;Init
S VALMCNT=0
Q
;
LMSEL() ;Return selection list
N IENLIST,IND,VALMY,XIEN
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q ""
S PXRMDONE=0,IENLIST=""
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the ien.
.S XIEN=^TMP("PXRMETH",$J,"SEL",IND)
.S IENLIST=$S(IENLIST'="":IENLIST_U_XIEN,1:XIEN)
Q IENLIST
;
PEXIT ;PXRM EXCH MENU protocol exit code
S VALMSG="+ Next Screen - Prev Screen ?? More Actions"
D XQORM
Q
;
SELECT(FREQ,SEL) ;Select extract period
;
N BDATE,EDATE,DA,DIE,DIK,DIR,DR,FDATE,VALID,X
;Get the new name.
F D Q:$D(DTOUT)!$D(DUOUT) Q:SEL]""
@ -183,41 +217,59 @@ SELECT(FREQ,SEL) ;Select extract period
.S SEL=Y
Q
;
TLIST ;Extract summary display
N IEN,IENLIST,IND
S IENLIST=$$LMSEL
F IND=1:1:$L(IENLIST,U) D
.S IEN=$P(IENLIST,U,IND)
.D START^PXRMETT(IEN)
.S VALMBCK="R"
TLIST ;Extract Totals
N IND,PXRMSIEN,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
;PXRMDONE is newed in PXRMLPM
S PXRMDONE=0
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the ien.
.S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
.D START^PXRMETT(PXRMSIEN)
;
S VALMBCK="R"
Q
;
TRANS ;Run Transmission
N IEN,IENLIST,IND
S IENLIST=$$LMSEL
F IND=1:1:$L(IENLIST,U) D
.S IEN=$P(IENLIST,U,IND)
.I $P($G(^PXRMXT(810.3,IEN,100)),U)'="N" D Q
..W !,"Local extracts cannot be transmitted to AAC." H 2
N IND,PXRMXIEN,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
S PXRMDONE=0
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the ien.
.S PXRMXIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
.I $P($G(^PXRMXT(810.3,PXRMXIEN,100)),U)'="N" D Q
..W !,"Local extracts cannot be transmitted to AAC." H 1
.;Transmit extract summary
.N ANS,DUOUT,DTOUT,RTN,TEXT
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
.I ANS D TRANS^PXRMETX(IEN)
.I ANS D TRANS^PXRMETX(PXRMXIEN)
;
;Rebuild workfile
D BLDLIST^PXRMETH1(EDIEN)
D BLDLIST^PXRMETH1(IEN)
;Refresh
S VALMBCK="R"
Q
;
TRHIST ;Transmission History
N IEN,IENLIST,IND
S IENLIST=$$LMSEL
F IND=1:1:$L(IENLIST,U) D
.S IEN=$P(IENLIST,U,IND)
.D START^PXRMETHL(IEN)
N IND,PXRMSIEN,VALMY
D EN^VALM2(XQORNOD(0))
;If there is no list quit.
I '$D(VALMY) Q
;PXRMDONE is newed in PXRMLPM
S PXRMDONE=0
S IND=""
F S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE) D
.;Get the ien.
.S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
.D START^PXRMETHL(PXRMSIEN)
;
S VALMBCK="R"
Q
;
@ -240,8 +292,11 @@ VALID(FREQ,INP) ;Validate Period input
Q 1
;
VIEW ;Select view
;
W IORESET
;
S VALMBCK="R"
;
N X,Y,CODE,DIR
K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="S"_U_"D:Sort by Creation Date;"
@ -258,7 +313,7 @@ VIEW ;Select view
S PXRMVIEW=Y
;
;Rebuild Workfile
D BLDLIST^PXRMETH1(EDIEN),HDR
D BLDLIST^PXRMETH1(IEN),HDR
Q
;
WARN(NEXT,STATUS) ;Warn if period is not completed
@ -272,68 +327,3 @@ WARN(NEXT,STATUS) ;Warn if period is not completed
;And Warn that period end date is a future date
W !!,"WARNING -This period is not complete until "_FDATE
Q
XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT HISTORY SELECT ENTRY",0))_U_"1:"_VALMCNT
S XQORM("A")="Select Item: "
Q
;
XSEL ;PXRM EXTRACT HISTORY SELECT ENTRY validation
N SEL,PXRMSIEN
S SEL=$P(XQORNOD(0),"=",2)
;Remove trailing ,
I $E(SEL,$L(SEL))="," S SEL=$E(SEL,1,$L(SEL)-1)
;Invalid selection
I SEL["," D Q
.W $C(7),!,"Only one item number allowed." H 2
.S VALMBCK="R"
I ('SEL)!(SEL>VALMCNT)!('$D(@VALMAR@("SEL",SEL))) D Q
.W $C(7),!,SEL_" is not a valid item number." H 2
.S VALMBCK="R"
;
;Get the list ien.
;S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",SEL,SEL)
S PXRMSIEN=^TMP("PXRMETH",$J,"SEL",SEL)
;
;Full screen mode
D FULL^VALM1
;
;Options
N X,Y,DIR,OPTION K DIROUT,DIRUT,DTOUT,DUOUT
S DIR(0)="SBM"_U_"DE:Delete Extract;"
S DIR(0)=DIR(0)_"ES:Extract Summary;"
S DIR(0)=DIR(0)_"MT:Manual Transmission;"
S DIR(0)=DIR(0)_"TH:Transmission History;"
S DIR("A")="Select Action"
S DIR("B")="ES"
S DIR("?")="Select from the codes displayed. For detailed help type ??"
S DIR("??")=U_"D HELP^PXRMETH1(1)"
D ^DIR K DIR
I $D(DIROUT) S DTOUT=1
I $D(DTOUT)!($D(DUOUT)) S VALMBCK="R" Q
S OPTION=Y
;
;Delete an extract
I OPTION="DE" D
.D DELETE^PXRMETXU(PXRMSIEN)
.;Rebuild workfile
.D BLDLIST^PXRMETH1(PXRMSIEN)
.;Refresh
.S VALMBCK="R"
;
;Display Extract Summary
I OPTION="ES" D START^PXRMETT(PXRMSIEN)
;
;Transmission option
I OPTION="MT" D
.N ANS,DUOUT,DTOUT,RTN,TEXT
.I $P($G(^PXRMXT(810.3,PXRMSIEN,100)),U)'="N" D Q
..W !,"Local extracts cannot be transmitted to AAC" H 2 Q
.S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
.S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
.I ANS D TRANS^PXRMETX(PXRMSIEN)
;
;Transmission History
I OPTION="TH" D START^PXRMETHL(PXRMSIEN)
;
S VALMBCK="R"
Q
;

Some files were not shown because too many files have changed in this diff Show More