revised back to 6/30/08 version

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m

@@ -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
+V ;;4.5;Accounts Receivable;**8,67,125,169**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
-	; DBIA 3820-A used for direct global read into file 399.
-	;
  ;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))
+BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN))
-	S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13)        ; IB claim status - DBIA3820-A
+ I '$D(^PRCA(430,PRCABN,2,0)) W !!,"**  This bill was cancelled in IB before it was passed to AR.  **",!,*7 G BEGIN
-	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
  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

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m

@@ -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"

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m

@@ -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 |"

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m

@@ -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")),"^"))

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDMC90.m

@@ -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
+V ;;4.5;Accounts Receivable;**45,108,133,121,163,190,192,236,237,229**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m

@@ -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)

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR2.m

@@ -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
+ ;;4.5;Accounts Receivable;**173,216,208,230**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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)=Bill ien^AR bill#^Service Date
-	;^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,"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 #"

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m

@@ -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)=" "

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR6.m

@@ -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
+ ;;4.5;Accounts Receivable;**173,214,208,230**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR9.m

@@ -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
+ ;;4.5;Accounts Receivable;**173**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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))"

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEWL0.m

@@ -1,11 +1,11 @@
-RCDPEWL0	;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;06 Jun 2007  11:50 AM
+RCDPEWL0 ;ALB/TMK - ELECTRONIC EOB WORKLIST ACTIONS ;26-NOV-02
-	;;4.5;Accounts Receivable;**173,208,252**;Mar 20, 1995;Build 63
+ ;;4.5;Accounts Receivable;**173,208**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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	;
+PARAMSQ I $G(RCQUIT) K ^TMP("RCERA_PARAMS",$J)
-	D PARAMS^RCDPEWLD(.RCQUIT)
  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 RCERADET D  ; Include formatted txt from 361.1 or 344.411
-	.. I 'RC3611 D  Q
+ .. 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

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m

@@ -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"

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPUDEP.m

@@ -1,6 +1,6 @@
-RCDPUDEP	;WISC/RFJ-deposit utilities ;29/MAY/2008
+RCDPUDEP ;WISC/RFJ-deposit utilities ;1 Jun 99
-	;;4.5;Accounts Receivable;**114,173,257**;Mar 20, 1995;Build 3
+ ;;4.5;Accounts Receivable;**114,173**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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
+ ;  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="" Q
+ 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=""
-	; 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
  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
+ ; deposit number space 269xxx, 369xxx, 469xxx, 569xxx
-	; and hasn't been previously entered via lockbox interface.
-	; 
  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
  ;

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m

@@ -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 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=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
+ .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"

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCMSITE.m

@@ -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
+V ;;4.5;Accounts Receivable;**173,236**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;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)
-	;

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m

@@ -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

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m

@@ -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
+ ;;4.5;Accounts Receivable;**201,228**;Mar 20, 1995
-	;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
  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 "399.0304:"
+ . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
-	.. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
+ . W RCXVU
-	.. W RCXVU
+ . F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)))  D
-	.. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)))  D
+ . . I RCXVCP>1 W "~"
-	... I RCXVCP>1 W "~"
+ . . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
-	... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
+ . . Q
-	... Q
+ . W !
-	.. W !
+ . I $D(^TMP($J,RCXVBLN,"4-399B",RCXVPC)) W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
-	. I $G(^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

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m

@@ -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
-	;
+D39942 ; CHARGES FROM 399.042
-	; *256 - loop through 399.042 to find CPT procedure
+ ; LOOP THRU 399.042
-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
  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 X=$P(RCXVD1,U,6)
-	S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt
+ 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-399B",RCXVPC)=RCXVDB
-	S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=""
-	S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
  Q
  ;

r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m

@@ -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"))

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m

@@ -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)

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAGUI1.m

@@ -1,5 +1,5 @@
-GMRAGUI1	;SLC/DAN - CPRS GUI support ;11/17/06  09:50
+GMRAGUI1 ;SLC/DAN - CPRS GUI support ;7/13/06  14:32
-	;;4.0;Adverse Reaction Tracking;**21,25,36,38**;Mar 29, 1996;Build 2
+ ;;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
  ;

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPET0.m

@@ -1,5 +1,5 @@
-GMRAPET0	;HIRMFO/RM-VERIFIED ALLERGY TASKS ;11/17/06  10:27
+GMRAPET0 ;HIRMFO/RM-VERIFIED ALLERGY TASKS ;4/7/06  12:38
-	;;4.0;Adverse Reaction Tracking;**6,17,21,20,38**;Mar 29, 1996;Build 2
+ ;;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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m

@@ -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
+ ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
-EN1	; This routine will loop through the GMRA patient allergy file
+EN1 ; This routine will loop thourgh the GMRA patient allergy file
-	; to find all patient within the date range that meet the criteria
+ ; 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"

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m

@@ -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)

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m

@@ -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)=""

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m

@@ -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

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m

@@ -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=""

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m

@@ -1,9 +1,5 @@
 GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ; 12/04/92
-	;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
+ ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
-	;
-	; Reference to $$PROD^XUPROD supported by DBIA 4440
-	; Reference to $$TESTPAT^VADPT supported by DBIA 3744
-	; 
  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:

r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m

@@ -1,5 +1,5 @@
-GMRAVFY	;HIRMFO/WAA,PWC-VERIFY AND SIGN OFF AN AGENT ; 5/23/07 10:32am
+GMRAVFY ;HIRMFO/WAA-VERIFY AND SIGN OFF AN AGENT ;12/1/95  16:06
-	;;4.0;Adverse Reaction Tracking;**2,33**;Mar 29, 1996;Build 5
+ ;;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

r/ASISTS-OOPS/OOPSGUIR.m

@@ -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

r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7ADL.m

@@ -1,5 +1,5 @@
-LA7ADL	;DALOI/JMC - Automatic Download of Test Orders;May 30, 2008
+LA7ADL ;DALOI/JMC - Automatic Download of Test Orders; 1/30/95 09:00
-	;;5.2;AUTOMATED LAB INSTRUMENTS;**17,25,23,57,66**;Sep 27, 1994;Build 30
+ ;;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
+ D BUILD
-	;  and build table of tests to check for downloading}
-	D XTMP,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
+ . I $$S^%ZTLOAD S TOUT=61,ZTSTOP=1 Q
-	. S TOUT=TOUT+1 H 5 D XTMP
+ . 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 ^TMP("LA7",$J),^TMP($J)
-	K LA7ADL,LA7AUTO,LA7NVAF,LRAA,LRAD,LRAN,TOUT
+ 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

r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7UID.m

@@ -1,49 +1,48 @@
-LA7UID	;DALIO/JRR - BUILD HL7 DOWNLOAD TO UI ;May 20, 2008
+LA7UID ;DALOI/JMC - BUILD HL7 DOWNLOAD TO UI; 12/3/1997
-	;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57,66**;Sep 27, 1994;Build 30
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**17,57**;Sep 27, 1994
-	;
  Q
  ;
-EN	; This line tag is called from ^LADOWN when downloading
+EN ;; This line tag is called from ^LADOWN when downloading
-	; a load work list to the Auto Instrument.  LADOWN1 should
+ ;  a load work list to the Auto Instrument.
-	; 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.
  ; 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,"^")
+ . I '$D(ZTQUEUED) D
-	. D ERROR,EXIT
-	. 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,"^")
+ . I '$D(ZTQUEUED) D
-	. D ERROR,EXIT
+ . . W $C(7),!!,"The STATUS field in the MESSAGE PARAMETER file must be "
-	. I '$D(ZTQUEUED) D  ;
-	. . W $C(7),!!,"The STATUS field in the LA7 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

r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN4.m

@@ -1,5 +1,5 @@
-LA7VIN4	;DALOI/JMC - Process Incoming UI Msgs, continued ; 7/27/07 11:24am
+LA7VIN4 ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
-	;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,66**;Sep 27, 1994;Build 30
+ ;;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
+ . I LA7AN>0 D SETID^LA7VHLU1(LA76249,LA7ID,LA7AN)
-	. D SETID^LA7VHLU1(LA76249,LA7ID,$S($G(LA7PNM)]"":LA7PNM,$G(LA7SSN)]"":LA7SSN,1:"NO ID"))
+ . 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

r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VIN5A.m

@@ -1,5 +1,5 @@
-LA7VIN5A	;DALOI/JMC - Process Incoming UI Msgs, continued ;May 29, 2008
+LA7VIN5A ;DALOI/JMC - Process Incoming UI Msgs, continued ; Jan 12, 2004
-	;;5.2;AUTOMATED LAB INSTRUMENTS;**46,64,67,72,66**;Sep 27, 1994;Build 30
+ ;;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.

r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m

@@ -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
+ 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
-	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 !,"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

r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m

@@ -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
  ;

r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m

@@ -1,6 +1,5 @@
-ALPBGEN1	;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
+ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003  07:59
-	;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
-	;;Per VHA Directive 2004-038, this routine should not be modified.
  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"

r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m

@@ -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
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
-	;;Per VHA Directive 2004-038, this routine should not be modified.
  ;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")

r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m

@@ -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
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
-	;;Per VHA Directive 2004-038, this routine should not be modified.
  ; 
  ; 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

r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m

@@ -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
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
-	;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
  ; 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

r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m

@@ -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

r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m

@@ -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))

r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m

@@ -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,

r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m

@@ -1,12 +1,12 @@
 PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
-	;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
+ ;;3.0;BAR CODE MED ADMIN;;Mar 2004
-	;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  ;
  ; 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

r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m

@@ -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,

r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m

@@ -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

r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m

@@ -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 X=DGBTM7 D COMMA^%DTC S DGBTM7=X
-	S X2="2$"  ;Reset edit mask to 2 decimal positions for rest of report
  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

r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m

@@ -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=""

r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m

@@ -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

r/BENEFICIARY_TRAVEL-DGBT/DGBTEF1.m

@@ -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"

r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m

@@ -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
+ ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
-	;
-	; 11/29/2007 BAY/KAM ROR*1.5*5 Rem Call 218601 Correct Outpatient
-	;                              CPTs not transmitting to the AAC
  ;
  ; 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")
-	.. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
+ . I $G(DIERR)  D  S ERRCNT=ERRCNT+1
-	.. I $G(DIERR)  D  S ERRCNT=ERRCNT+1
+ . . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
-	... D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
-	. E  S PRV=""
-	. ;----------> End of changes for 218601
  . ;---
  . D SETOBX(OID,PROC,PRV)
  Q ERRCNT

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

@@ -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.
+ ;Q
-PRGDUP	;Purge Duplicate Entries; retain most recent for all except types.
+PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234.
-	;**50 through remainder of module.
  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(^RGHL7(991.1,IEN,0),"^",3)
-	.... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
  .... 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)
+ ..... S OLDDT=$P(OLDNODE,"^")
-	..... I EXCDT>OLDDT D  Q  ;incoming date greater than previous? purge old, keep new.
+ ..... 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 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA
-	...... I NUM>1 D
+ ...... E  I NUM>1 D
-	....... S DA(1)=OLDIEN,DA=OLDIEN2
+ ....... 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
-	..... I OLDDT>EXCDT!(OLDDT=EXCDT) D  ;previous date greater or equal incoming? purge new, keep old.
  ...... 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 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
-	...... I NUM>1 D DEL
+ ...... E  I NUM>1 D DEL
-	...... ;
+ ; W !,CNT_" Duplicate entries"
-	K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
+ ;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 EXCTYP=""
-	;S HOME=$$SITE^VASITE()
+ S HOME=$$SITE^VASITE()
-	;F  S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP  D
+ F  S EXCTYP=$O(^RGHL7(991.1,"AC",EXCTYP)) Q:'EXCTYP  D
-	;. I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D  ;**43
+ . I (EXCTYP=209)!(EXCTYP=227)!(EXCTYP=213)!(EXCTYP=214) D  ;**43
-	;.. S IEN=0
+ .. S IEN=0
-	;.. F  S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN  D
+ .. F  S IEN=$O(^RGHL7(991.1,"AC",EXCTYP,IEN)) Q:'IEN  D
-	;... S IEN2=0,ICN="",RGDFN=""
+ ... S IEN2=0,ICN="",RGDFN=""
-	;... F  S IEN2=$O(^RGHL7(991.1,"AC",EXCTYP,IEN,IEN2)) Q:'IEN2  D
+ ... 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 RGDFN=$P(^RGHL7(991.1,IEN,1,IEN2,0),"^",4) Q:'RGDFN
-	;.... S ICN=+$$GETICN^MPIF001(RGDFN)
+ .... S ICN=+$$GETICN^MPIF001(RGDFN)
-	;.... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
+ .... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
-	;..... L +^RGHL7(991.1,IEN):10
+ ..... L +^RGHL7(991.1,IEN):10
-	;..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
+ ..... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
-	;..... D ^DIE K DIE,DA,DR
+ ..... D ^DIE K DIE,DA,DR
-	;..... L -^RGHL7(991.1,IEN)
+ ..... L -^RGHL7(991.1,IEN)
-	;K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
+ K EXCTYP,HOME,ICN,IEN,IEN2,RGDFN
  Q

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

@@ -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)
+ Q:'$D(DFN)
-	;S EXCTYP=""
+ S EXCTYP=""
-	;S HOME=$$SITE^VASITE()
+ S HOME=$$SITE^VASITE()
-	;F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
+ F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
-	;. S RGDFN="",ICN=""
+ . S RGDFN="",ICN=""
-	;. F  S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN  D
+ . F  S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN  D
-	;.. I DFN=RGDFN D
+ .. I DFN=RGDFN D
-	;... S ICN=+$$GETICN^MPIF001(DFN)
+ ... S ICN=+$$GETICN^MPIF001(DFN)
-	;... ;Only set to PROCESSED if patient has national ICN.
+ ... ;Only set to PROCESSED if patient has national ICN.
-	;... I $E(ICN,1,3)'=$E($P(HOME,"^",3),1,3)&(ICN>0) D
+ ... 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 Death exceptions (215-217); they must be processed manually.
-	;.... ;Exclude 218 Potential Matches Returned exception **43
+ .... ;Exclude 218 Potential Matches Returned exception **43
-	;.... I (EXCTYP>218)!(EXCTYP<215) D
+ .... I (EXCTYP>218)!(EXCTYP<215) D
-	;..... S IEN=0
+ ..... S IEN=0
-	;..... F  S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN  D
+ ..... F  S IEN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN)) Q:'IEN  D
-	;...... S IEN2=0
+ ...... S IEN2=0
-	;...... F  S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2  D
+ ...... F  S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2  D
-	;....... L +^RGHL7(991.1,IEN):10
+ ....... L +^RGHL7(991.1,IEN):10
-	;....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
+ ....... S DA(1)=IEN,DA=IEN2,DR="6///"_1,DIE="^RGHL7(991.1,"_DA(1)_",1,"
-	;....... D ^DIE K DIE,DA,DR
+ ....... D ^DIE K DIE,DA,DR
-	;....... L -^RGHL7(991.1,IEN)
+ ....... L -^RGHL7(991.1,IEN)
-	;K IEN,IEN2,RGDFN,EXCTYP,ICN
+ K IEN,IEN2,RGDFN,EXCTYP,ICN
  Q
 PDAT ;
  K DIRUT

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

@@ -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

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

@@ -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

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

@@ -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
+ .; 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=218) D  ;**43,**45,**52
+ . 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)

r/CLINICAL_PROCEDURES-MD/MDAPI.m

@@ -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)=""
+ ..S:'MDPPR MDPPR=$P(MDCHK,U,4)
-	..D FILE^DIE("","MDFDA") K MDFDA
+ ..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
-	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
  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

r/CLINICAL_PROCEDURES-MD/MDHL7A.m

@@ -1,10 +1,9 @@
-MDHL7A	; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07  08:17
+MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38]
-	;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+ ;;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 #2701 [Supported] for MPIF001 Calls
-	; Reference DBIA #10096 [Supported] for ^%ZOSF 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)=""
+ 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),"")
-	S ^TMP($J,"MDHL7A1")=""
+ K HLNODE
-	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")
  ;
 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
+ I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID
-	. S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
-	. S MDNO=$$NTIU^MDRPCW1(+MDD702)
-	. Q
  ; ^^--- Create Subfile and quit
  Q "-1"  ; Unable to create file
  ;

r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m

@@ -1,9 +1,8 @@
-MDHL7MCA	; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
+MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
-	;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+ ;;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

r/CLINICAL_PROCEDURES-MD/MDHL7U3.m

@@ -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
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
-	; Reference DBIA #2729 [Supported]  for XMXPAI
  ; 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

r/CLINICAL_PROCEDURES-MD/MDHL7X.m

@@ -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)

r/CLINICAL_PROCEDURES-MD/MDRPCOG.m

@@ -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")

r/CLINICAL_PROCEDURES-MD/MDRPCOP.m

@@ -1,20 +1,21 @@
-MDRPCOP	; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08  09:16
+MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21]
-	;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102
+ ;;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
+ K ^TMP("MDTMP",$J)
-	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
  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")
+ .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)
-	.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 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
+ 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),MDTDF=DFN
+ S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
-	S BEG=$$X2FM($$GETBEG),END=$$X2FM($$GETEND)+0.2359
+ 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(.RESULTS,DFN,DATA,1)
-	D NOTICE^DGSEC4(.RES,DFN,DATA,1)
+ S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log")
-	S @RESULTS@(0)=$S(+RES:"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
+ I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q
-	D SELECT^MDRPCOP1
+ 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

r/CLINICAL_PROCEDURES-MD/MDRPCOT.m

@@ -1,5 +1,5 @@
-MDRPCOT	; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08  09:18
+MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02  15:33
-	;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102
+ ;;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.

r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m

@@ -1,5 +1,5 @@
-PXRM7M1	;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007  15:26
+PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 03/21/2002 ;4/11/02  15:26
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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

r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m

@@ -1,12 +1,11 @@
-PXRM7XT	;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007
+PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 03/21/2002 ;4/11/02  15:26
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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

r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m

@@ -1,5 +1,5 @@
-PXRMCDUE	;SLC/PKR - Custom date due calculation routines. ;09/05/2007
+PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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)
+ . S DATE=+$G(FIEVAL(FI,"DATE"))
-	. I DATE>0 S DATE=$$FULLDATE^PXRMDATE(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)

r/CLINICAL_REMINDERS-PXRM/PXRMCF.m

@@ -1,5 +1,5 @@
-PXRMCF	; SLC/PKR - Handle computed findings. ;07/25/2007
+PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
-	;Make sure NGET has the same sign as NOCC.
-	I NGET'=NOCC S NGET=NGET*($$ABS^XLFMTH(NOCC)/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

r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m

@@ -1,5 +1,5 @@
-PXRMCOND	; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
+PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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=$S(COND="":0,1:$P(CONDS,U,3))
-	S UCIFS=$P(CONDS,U,3)
  I COND="" Q
  S CASESEN=$P(CONDS,U,2)
  I CASESEN="" S CASESEN=1

r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m

@@ -1,5 +1,5 @@
-PXRMCOPY	; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007
+PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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
  ;

r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m

@@ -1,5 +1,5 @@
-PXRMDATA	; SLC/PKR - Routines for getting data. ;04/02/2007
+PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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
  ;

r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m

@@ -1,5 +1,5 @@
-PXRMDATE	; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
+PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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
+ N %DT,X,Y
-	;Already a FileMan date?
-	S ND=+DATE
-	I (ND'<1000000),(ND'>9991231) Q DATE
  ;Check for a date FileMan understands.
  S X=DATE,%DT="ST"
  D ^%DT

r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m

@@ -1,11 +1,10 @@
-PXRMDBL3	; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007
+PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;04/30/2001
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ; Called from PXRMDBL1
  ;
  ;Set number range for site
-START	;
+START D SETSTART^PXRMCOPY("^PXRMD(801.41,")
-	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,IEN,0)),U)
-	S YT("CODE")=$P($G(^YTT(601.71,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

r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m

@@ -1,5 +1,5 @@
-PXRMDEDT	; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007
+PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;07/28/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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

r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m

@@ -1,5 +1,5 @@
-PXRMDEV	; SLC/PKR - This is a driver for testing Clinical Reminders.;01/24/2007
+PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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

r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m

@@ -1,5 +1,5 @@
-PXRMDLG4	; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007
+PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;10/31/2005
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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_"]"

r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m

@@ -1,20 +1,6 @@
-PXRMDLG5	; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007
+PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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
-	;

r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m

@@ -1,5 +1,5 @@
-PXRMDLGZ	; SLC/PJH - Link reminder to dialog. ;01/11/2007
+PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;05/31/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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 $P(X,";",2)'="YTT(601," Q 1
-	I $$OK^PXRMDLL($P(X,";")) 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

r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m

@@ -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
+ I 'DFIEN Q 0
-	Q $$MH^PXRMDLG5(DIEN)
+ 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 DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
-	.S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)
-	.;S 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 DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
-	.S DRESL=$$RESGROUP^PXRMDLLB(DITEM)
-	.;S 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))

r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m

@@ -1,5 +1,5 @@
-PXRMDLLA	;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
+PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
-	..I $P($G(^YTT(601.71,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)
+ ..S $P(ORY(OCNT),U,13)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0)
-	..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
  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"

r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m

@@ -1,5 +1,5 @@
-PXRMDLLB	;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
+PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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

r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m

@@ -1,32 +1,24 @@
-PXRMDLR	;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
+PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;06/09/2000
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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)
+ .D PREVIEW^YTAPI4(.ARRAY,.YT)
-	.K YT("R1")
+ .I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
-	.D CHECKCR^YTQPXRM4(.ARRAY,.YT)
+ .S SUB=0,OK=0
-	.S OK=0
+ .F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
-	.;D PREVIEW^YTAPI4(.ARRAY,.YT)
+ ..I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
-	.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
  .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)

r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m

@@ -1,5 +1,5 @@
-PXRMDLR1	; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007
+PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 02/04/2004
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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

r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m

@@ -1,5 +1,5 @@
-PXRMDNVA	; SLC/PKR - Handle non-VA med findings. ;03/14/2007
+PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;05/24/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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 TEMP=TEMP_" - "_$$EDATE^PXRMDATE(IFIEVAL("STOP DATE"))_")"
-	S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
  D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
  Q

r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m

@@ -1,5 +1,5 @@
-PXRMDRGR	; SLC/PKR - Handle groups of drug findings. ;06/20/2007
+PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/12/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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
-	;

r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m

@@ -1,5 +1,5 @@
-PXRMDRUG	; SLC/PKR - Handle drug findings. ;04/23/2007
+PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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
+ .. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN
-	.. S JND=0
-	.. F  S JND=+$O(TFIEVAL(TFINDING,JND)) Q:JND=0  S TFIEVAL(TFINDING,JND,"DISPENSE DRUG")=DRUGIEN
  Q
  ;
  ;===============================================

r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m

@@ -1,17 +1,14 @@
-PXRMEDIT	; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007
+PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;05/18/2000
-	;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;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)

r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m

@@ -1,5 +1,5 @@
-PXRMENOD	; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006
+PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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)=""
-	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)=""
-	I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
  Q
  ;

r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m

@@ -1,5 +1,5 @@
-PXRMEPM	; SLC/PKR/PJH - Extract Definition Management ;07/17/2007
+PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;06/21/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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"

r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m

@@ -1,5 +1,5 @@
-PXRMETCO	; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007
+PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;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
+ .S PXRMLIST=$$CRLST^PXRMRULE(LIST_" "_SUFFIX) Q:'PXRMLIST
-	.D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,INDP,INTP)
+ .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")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
-	S DIR("A")="Start the task at: "
  S DIR(0)="DAU"_U_MINDT_"::RSX"
  D ^DIR
  I $D(DTOUT)!$D(DUOUT) Q

r/CLINICAL_REMINDERS-PXRM/PXRMETH.m

@@ -1,13 +1,12 @@
-PXRMETH	; SLC/PJH - Reminder Extract History ;10/11/2007
+PXRMETH ; SLC/PJH - Reminder Extract History ;08/15/2006
-	;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM EXTRACT HISTORY
-START(EDIEN)	;
+START(IEN) ;
-	;EDIEN is the extract definition 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 DATA=$G(^PXRM(810.2,IEN,0))
-	S NAT=$P($G(^PXRM(810.2,EDIEN,100)),U)
+ 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 ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)"
-	S ZTSAVE("EDIEN")=""
+ 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
+TLIST ;Extract Totals
-	N IEN,IENLIST,IND
+ N IND,PXRMSIEN,VALMY
-	S IENLIST=$$LMSEL
+ D EN^VALM2(XQORNOD(0))
-	F IND=1:1:$L(IENLIST,U) D
+ ;If there is no list quit.
-	.S IEN=$P(IENLIST,U,IND)
+ I '$D(VALMY) Q
-	.D START^PXRMETT(IEN)
+ ;PXRMDONE is newed in PXRMLPM
-	.S VALMBCK="R"
+ 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
+ N IND,PXRMXIEN,VALMY
-	S IENLIST=$$LMSEL
+ D EN^VALM2(XQORNOD(0))
-	F IND=1:1:$L(IENLIST,U) D
+ ;If there is no list quit.
-	.S IEN=$P(IENLIST,U,IND)
+ I '$D(VALMY) Q
-	.I $P($G(^PXRMXT(810.3,IEN,100)),U)'="N" D  Q
+ S PXRMDONE=0
-	..W !,"Local extracts cannot be transmitted to AAC." H 2
+ 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
+ N IND,PXRMSIEN,VALMY
-	S IENLIST=$$LMSEL
+ D EN^VALM2(XQORNOD(0))
-	F IND=1:1:$L(IENLIST,U) D
+ ;If there is no list quit.
-	.S IEN=$P(IENLIST,U,IND)
+ I '$D(VALMY) Q
-	.D START^PXRMETHL(IEN)
+ ;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
-	;