Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCACM.m	(revision 636)
@@ -1,7 +1,5 @@
 PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95  2:41 PM
- ;;4.5;Accounts Receivable;**8,67,125,169,254**;Mar 20, 1995;Build 2
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ; DBIA 3820-A used for direct global read into file 399.
- ;
+V ;;4.5;Accounts Receivable;**8,67,125,169**;Mar 20, 1995
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;This is a routine for adjustment transaction.
  NEW PRCABN,PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
@@ -57,9 +55,6 @@
  S %DT="AERX",%DT(0)=% D ^%DT
  Q Y
-BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE"),PRCAIBS D BILL^PRCAUTL Q:('$D(PRCABN))
- S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13)        ; IB claim status - DBIA3820-A
- I PRCAIBS=1 W !!,"**  You cannot add AR Comments to an Entered/Not Reviewed claim.  **",!,*7 G BEGIN
- I PRCAIBS=2 W !!,"**  You cannot add AR Comments to an MRA Request claim.  **",!,*7 G BEGIN
- I '$D(^PRCA(430,PRCABN,2,0)),PRCAIBS=7 W !!,"**  You cannot add AR Comments to a claim Cancelled/not passed to AR.  **",!,*7 G BEGIN
+BEGIN K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN))
+ I '$D(^PRCA(430,PRCABN,2,0)) W !!,"**  This bill was cancelled in IB before it was passed to AR.  **",!,*7 G BEGIN
  I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"**  Comments CANNOT be entered on an ARCHIVED bill.  **",!,*7 G BEGIN
  D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -12,5 +12,5 @@
  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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGST1.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -59,5 +59,5 @@
  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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCASVC.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -9,5 +9,5 @@
 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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEM.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -25,5 +25,5 @@
  ; '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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPESR3.m	(revision 636)
@@ -1,4 +1,4 @@
 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
  ;
@@ -72,5 +72,5 @@
  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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCDPEX32.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
  ;
@@ -48,5 +48,5 @@
  .. 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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCFMOBR.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -75,12 +75,7 @@
 EN3 ;Deletes OBRs over 60 days old
  N A0,A1,A2,DA,DIK,X,X1,X2
- S A0="OBR-" F  S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-")  S A1=$E($P(A0,"-",2),1,8),A2=0 F  S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0  D
- .S X1=DT,X2=$$RCDT(A1) D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
+ S A0="OBR-" F  S A0=$O(^PRCF(423.6,"B",A0)) Q:A0=""!(A0'["OBR-")  S A1=2_$E($P(A0,"-",2),3,8),A2=0 F  S A2=$O(^PRCF(423.6,"B",A0,A2)) Q:+A2=0  D
+ .S X1=DT,X2=A1 D ^%DTC I X>60 S DIK="^PRCF(423.6,",DA=A2 D ^DIK
  Q
-RCDT(A1) ;Convert yyyymmdd to FM date
- N X,Y
- S X=A1,X=$E(X,5,6)_" "_$E(X,7,8)_", "_$E(X,1,4)
- D ^%DT
- Q Y
 PURGE ;purge unprocessed document file
  N DIR,Y,X,X1,X2,RCDT
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCXM1.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
  ;
@@ -40,5 +40,5 @@
  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
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC.m	(revision 636)
@@ -1,5 +1,4 @@
 RCXVDC ;DAOU/ALA-AR Data Extraction Data Creation ;02-JUL-03
- ;;4.5;Accounts Receivable;**201,228,256**;Mar 20, 1995;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;4.5;Accounts Receivable;**201,228**;Mar 20, 1995
  ;
  Q
@@ -29,14 +28,13 @@
  S RCXVPC=0
  F  S RCXVPC=$O(^TMP($J,RCXVBLN,"4-399A",RCXVPC))  Q:'RCXVPC  D
- . I $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))'="" D
- .. W "399.0304:"
- .. W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
- .. W RCXVU
- .. F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)))  D
- ... I RCXVCP>1 W "~"
- ... W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
- ... Q
- .. W !
- . I $G(^TMP($J,RCXVBLN,"4-399B",RCXVPC))'="" W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
+ . W "399.0304:"
+ . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC))
+ . W RCXVU
+ . F RCXVCP=1:1 Q:('$D(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP)))  D
+ . . I RCXVCP>1 W "~"
+ . . W $G(^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVCP))
+ . . Q
+ . W !
+ . I $D(^TMP($J,RCXVBLN,"4-399B",RCXVPC)) W "399.042:"_$G(^TMP($J,RCXVBLN,"4-399B",RCXVPC)),!
  . Q
  S RCXVI=""
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVDC4.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
  ;
@@ -8,11 +8,9 @@
  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
+ S RCXVPC=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
  Q
 D399PCA ;
@@ -43,5 +41,5 @@
  ;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
@@ -54,42 +52,18 @@
  . S RCXVMULT=RCXVMULT+1
  . S RCXVP2=$P($G(^DIC(81.3,RCXVP1,0)),U,1)
- . S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT,RCXVMULT)=RCXVP2
+ . S ^TMP($J,RCXVBLN,"4-399A",RCXVPC,RCXVMULT)=RCXVP2
  . Q
- ;
- ; *256 - loop through 399.042 to find CPT procedure
-MATCH N RCXVCPT1,RCXVFND,X
- S RCXVCPT1=$P(RCXVD,";",1)  ;proc
- S (RCXVFND,RCXVCP)=0
- F  S RCXVCP=$O(^DGCR(399,RCXVD0,"RC",RCXVCP)) Q:'RCXVCP!RCXVFND  D
- . Q:$F(RCXVMH,";"_RCXVCP)  ;quit if CPT proc match
- . S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVCP,0))
- . Q:RCXVD1=""
- . S X=$P(RCXVD1,U,6)  ;CPT proc
- . I RCXVCPT1'="",X'="",RCXVCPT1=X D
- .. S RCXVFND=1
- .. S X=$P(RCXVD1,U)
- .. S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
- .. S X=$P(RCXVD1,U,6)
- .. S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
- .. S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
- .. S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
- .. S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
- .. S RCXVMH=RCXVMH_";"_RCXVCP
- I 'RCXVFND S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=""
- Q
- ;  
-D39942 ; charge
+D39942 ; CHARGES FROM 399.042
+ ; LOOP THRU 399.042
  N X
- Q:$F(RCXVMH,";"_RCXVPC)
  S RCXVD1=$G(^DGCR(399,RCXVD0,"RC",RCXVPC,0))
- Q:RCXVD1=""
+ I RCXVD1="" Q
  S X=$P(RCXVD1,U)
  S RCXVDB=RCXVBLNA_RCXVU_$$GET1^DIQ(399.2,X_",",.01,"E") ; Revenue Code
- S RCXVDB=RCXVDB_RCXVU_""  ;No CPT proc
- S RCXVDB=RCXVDB_RCXVU_"" ; No proc dt
+ S X=$P(RCXVD1,U,6)
+ S RCXVDB=RCXVDB_RCXVU_$$GET1^DIQ(81,X_",",.01,"E") ; Procedures [P]
+ S RCXVDB=RCXVDB_RCXVU_RCXVPCDT ; PROC. DT
  S RCXVDB=RCXVDB_RCXVU_$P(RCXVD1,U,2) ; Charges
- S RCXVCNT=RCXVCNT+1
- S ^TMP($J,RCXVBLN,"4-399A",RCXVCNT)=""
- S ^TMP($J,RCXVBLN,"4-399B",RCXVCNT)=RCXVDB
+ S ^TMP($J,RCXVBLN,"4-399B",RCXVPC)=RCXVDB
  Q
  ;
Index: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m
===================================================================
--- FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m	(revision 631)
+++ FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVFTP.m	(revision 636)
@@ -1,4 +1,4 @@
 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**
@@ -32,5 +32,5 @@
  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"
  ;
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRACMR4.m	(revision 636)
@@ -1,7 +1,7 @@
-GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ;10/1/92
- ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
+GMRACMR4 ;HIRMFO/WAA-PATIENT NOT ASKED ABOUT ALLERGIES ; 10/1/92
+ ;;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"
@@ -31,5 +31,4 @@
  .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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRADSP5.m	(revision 636)
@@ -1,4 +1,4 @@
-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
+GMRADSP5 ;HIRMFO/YMP,RM,WAA-LISTING OF ALLERGIES TO SIGNED OFF ALLERGIES ; 8/16/92
+ ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
 EN1 ; Entry to PATIENT ALLERGIES NOT SIGNED OFF option
  S GMRAOUT=0
@@ -14,5 +14,4 @@
 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_")"
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAEF2.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -21,5 +21,4 @@
  .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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAFDA3.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -41,5 +41,4 @@
  .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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPFT.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -31,5 +31,4 @@
  ..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"
@@ -47,5 +46,5 @@
  ..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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPL.m	(revision 636)
@@ -1,6 +1,6 @@
 GMRAPL ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION ;5/2/97  14:13
- ;;4.0;Adverse Reaction Tracking;**7,33**;Mar 29, 1996;Build 5
-EN1 ; This routine will loop through the GMRA patient allergy file
- ; to find all patient within the date range that meet the criteria
+ ;;4.0;Adverse Reaction Tracking;**7**;Mar 29, 1996
+EN1 ; This routine will loop thourgh the GMRA patient allergy file
+ ; to find all patient within the date range that meet the critera
  ; and then display all the data for those patients first by location
  ; then by date/time range of the reaction.
@@ -32,5 +32,4 @@
  ..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)
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPNA.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -6,5 +6,5 @@
  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"
@@ -37,5 +37,4 @@
  ..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)
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST1.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -31,5 +31,4 @@
  ..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)
@@ -68,5 +67,5 @@
  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)
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST2.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -28,5 +28,4 @@
  ..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
@@ -58,5 +57,5 @@
  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)
@@ -78,5 +77,5 @@
  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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST3.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -31,5 +31,4 @@
  ..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
@@ -60,5 +59,5 @@
  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)
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST4.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -30,5 +30,4 @@
  ..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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST5.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -28,5 +28,4 @@
  ..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
@@ -38,5 +37,5 @@
  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)
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST6.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -34,5 +34,4 @@
  ..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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPST7.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -35,5 +35,4 @@
  ..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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAPU.m	(revision 636)
@@ -1,4 +1,4 @@
-GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ;8/27/93
- ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
+GMRAPU ;HIRMFO/WAA- PRINT ALLERGY LIST BY LOCATION UNVERIFIED ; 8/27/93
+ ;;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
@@ -67,5 +67,4 @@
  .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)
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAUTL1.m	(revision 636)
@@ -1,8 +1,4 @@
-GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ;12/04/92
- ;;4.0;Adverse Reaction Tracking;**33**;Mar 29, 1996;Build 5
- ;
- ; Reference to $$PROD^XUPROD supported by DBIA 4440
- ; Reference to $$TESTPAT^VADPT supported by DBIA 3744
- ; 
+GMRAUTL1 ;HIRMFO/WAA-ALLERGY UTILITIES ; 12/04/92
+ ;;4.0;Adverse Reaction Tracking;;Mar 29, 1996
  Q
 STPCK() ; This is to check to see if the user wanted to stop the print
@@ -47,14 +43,4 @@
  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
Index: FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m
===================================================================
--- FOIAVistA/trunk/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m	(revision 631)
+++ FOIAVistA/tag/r/ADVERSE_REACTION_TRACKING-GMRA-GMA/GMRAVFY.m	(revision 636)
@@ -1,4 +1,4 @@
-GMRAVFY ;HIRMFO/WAA,PWC-VERIFY AND SIGN OFF AN AGENT ; 5/23/07 10:32am
- ;;4.0;Adverse Reaction Tracking;**2,33**;Mar 29, 1996;Build 5
+GMRAVFY ;HIRMFO/WAA-VERIFY AND SIGN OFF AN AGENT ;12/1/95  16:06
+ ;;4.0;Adverse Reaction Tracking;**2**;Mar 29, 1996
 EN1 ;This is the main entry point for the verifier option.
  S GMRAVER=0,GMRADRUG=0
@@ -27,6 +27,5 @@
  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)
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX0.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX0.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX0.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX0 ; DRIVER FOR COMPILED XREFS FOR FILE #357 ; 10/15/04
+IBDX0 ; DRIVER FOR COMPILED XREFS FOR FILE #357 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX01.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX01.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX01.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX01 ; COMPILED XREF FOR FILE #357 ; 10/15/04
+IBDX01 ; COMPILED XREF FOR FILE #357 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX02.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX02.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX02.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX02 ; COMPILED XREF FOR FILE #357.02 ; 10/15/04
+IBDX02 ; COMPILED XREF FOR FILE #357.02 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX03.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX03.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX03.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX03 ; COMPILED XREF FOR FILE #357 ; 10/15/04
+IBDX03 ; COMPILED XREF FOR FILE #357 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX04.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX04.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX04.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX04 ; COMPILED XREF FOR FILE #357.02 ; 10/15/04
+IBDX04 ; COMPILED XREF FOR FILE #357.02 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX1.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX1.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX1.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX1 ; DRIVER FOR COMPILED XREFS FOR FILE #357.1 ; 10/15/04
+IBDX1 ; DRIVER FOR COMPILED XREFS FOR FILE #357.1 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX11.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX11.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX11.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX11 ; COMPILED XREF FOR FILE #357.1 ; 10/15/04
+IBDX11 ; COMPILED XREF FOR FILE #357.1 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX110.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX110.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX110.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX110 ; COMPILED XREF FOR FILE #357.14 ; 10/15/04
+IBDX110 ; COMPILED XREF FOR FILE #357.14 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX12.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX12.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX12.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX12 ; COMPILED XREF FOR FILE #357.11 ; 10/15/04
+IBDX12 ; COMPILED XREF FOR FILE #357.11 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX13.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX13.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX13.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX13 ; COMPILED XREF FOR FILE #357.12 ; 10/15/04
+IBDX13 ; COMPILED XREF FOR FILE #357.12 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX14.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX14.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX14.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX14 ; COMPILED XREF FOR FILE #357.13 ; 10/15/04
+IBDX14 ; COMPILED XREF FOR FILE #357.13 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX15.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX15.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX15.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX15 ; COMPILED XREF FOR FILE #357.14 ; 10/15/04
+IBDX15 ; COMPILED XREF FOR FILE #357.14 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX16.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX16.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX16.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX16 ; COMPILED XREF FOR FILE #357.1 ; 10/15/04
+IBDX16 ; COMPILED XREF FOR FILE #357.1 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX17.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX17.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX17.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX17 ; COMPILED XREF FOR FILE #357.11 ; 10/15/04
+IBDX17 ; COMPILED XREF FOR FILE #357.11 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX18.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX18.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX18.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX18 ; COMPILED XREF FOR FILE #357.12 ; 10/15/04
+IBDX18 ; COMPILED XREF FOR FILE #357.12 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX19.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX19.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX19.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX19 ; COMPILED XREF FOR FILE #357.13 ; 10/15/04
+IBDX19 ; COMPILED XREF FOR FILE #357.13 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX2.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX2.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX2.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX2 ; DRIVER FOR COMPILED XREFS FOR FILE #357.2 ; 10/15/04
+IBDX2 ; DRIVER FOR COMPILED XREFS FOR FILE #357.2 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX21.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX21.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX21.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX21 ; COMPILED XREF FOR FILE #357.2 ; 10/15/04
+IBDX21 ; COMPILED XREF FOR FILE #357.2 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX22.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX22.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX22.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX22 ; COMPILED XREF FOR FILE #357.21 ; 10/15/04
+IBDX22 ; COMPILED XREF FOR FILE #357.21 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX23.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX23.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX23.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX23 ; COMPILED XREF FOR FILE #357.22 ; 10/15/04
+IBDX23 ; COMPILED XREF FOR FILE #357.22 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX24.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX24.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX24.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX24 ; COMPILED XREF FOR FILE #357.2 ; 10/15/04
+IBDX24 ; COMPILED XREF FOR FILE #357.2 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX25.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX25.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX25.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX25 ; COMPILED XREF FOR FILE #357.21 ; 10/15/04
+IBDX25 ; COMPILED XREF FOR FILE #357.21 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX26.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX26.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX26.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX26 ; COMPILED XREF FOR FILE #357.22 ; 10/15/04
+IBDX26 ; COMPILED XREF FOR FILE #357.22 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX3.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX3.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX3.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX3 ; DRIVER FOR COMPILED XREFS FOR FILE #357.3 ; 10/15/04
+IBDX3 ; DRIVER FOR COMPILED XREFS FOR FILE #357.3 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX31.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX31.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX31.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX31 ; COMPILED XREF FOR FILE #357.3 ; 10/15/04
+IBDX31 ; COMPILED XREF FOR FILE #357.3 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX32.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX32.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX32.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX32 ; COMPILED XREF FOR FILE #357.31 ; 10/15/04
+IBDX32 ; COMPILED XREF FOR FILE #357.31 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX33.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX33.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX33.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX33 ; COMPILED XREF FOR FILE #357.33 ; 10/15/04
+IBDX33 ; COMPILED XREF FOR FILE #357.33 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX34.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX34.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX34.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX34 ; COMPILED XREF FOR FILE #357.3 ; 10/15/04
+IBDX34 ; COMPILED XREF FOR FILE #357.3 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX35.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX35.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX35.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX35 ; COMPILED XREF FOR FILE #357.31 ; 10/15/04
+IBDX35 ; COMPILED XREF FOR FILE #357.31 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX36.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX36.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX36.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX36 ; COMPILED XREF FOR FILE #357.33 ; 10/15/04
+IBDX36 ; COMPILED XREF FOR FILE #357.33 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX4.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX4.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX4.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX4 ; DRIVER FOR COMPILED XREFS FOR FILE #357.4 ; 10/15/04
+IBDX4 ; DRIVER FOR COMPILED XREFS FOR FILE #357.4 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX41.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX41.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX41.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX41 ; COMPILED XREF FOR FILE #357.4 ; 10/15/04
+IBDX41 ; COMPILED XREF FOR FILE #357.4 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX42.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX42.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX42.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX42 ; COMPILED XREF FOR FILE #357.4 ; 10/15/04
+IBDX42 ; COMPILED XREF FOR FILE #357.4 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX5.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX5.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX5.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX5 ; DRIVER FOR COMPILED XREFS FOR FILE #357.5 ; 10/15/04
+IBDX5 ; DRIVER FOR COMPILED XREFS FOR FILE #357.5 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX51.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX51.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX51.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX51 ; COMPILED XREF FOR FILE #357.5 ; 10/15/04
+IBDX51 ; COMPILED XREF FOR FILE #357.5 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX52.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX52.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX52.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX52 ; COMPILED XREF FOR FILE #357.52 ; 10/15/04
+IBDX52 ; COMPILED XREF FOR FILE #357.52 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX53.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX53.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX53.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX53 ; COMPILED XREF FOR FILE #357.5 ; 10/15/04
+IBDX53 ; COMPILED XREF FOR FILE #357.5 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX54.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX54.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX54.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX54 ; COMPILED XREF FOR FILE #357.52 ; 10/15/04
+IBDX54 ; COMPILED XREF FOR FILE #357.52 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX95.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX95.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX95.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX95 ; DRIVER FOR COMPILED XREFS FOR FILE #357.95 ; 10/15/04
+IBDX95 ; DRIVER FOR COMPILED XREFS FOR FILE #357.95 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX951.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX951.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX951.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX951 ; COMPILED XREF FOR FILE #357.95 ; 10/15/04
+IBDX951 ; COMPILED XREF FOR FILE #357.95 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9510.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9510.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9510.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX9510 ; COMPILED XREF FOR FILE #357.9511 ; 10/15/04
+IBDX9510 ; COMPILED XREF FOR FILE #357.9511 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9511.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9511.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9511.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX9511 ; COMPILED XREF FOR FILE #357.952 ; 10/15/04
+IBDX9511 ; COMPILED XREF FOR FILE #357.952 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9512.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9512.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX9512.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX9512 ; COMPILED XREF FOR FILE #357.953 ; 10/15/04
+IBDX9512 ; COMPILED XREF FOR FILE #357.953 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX952.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX952.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX952.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX952 ; COMPILED XREF FOR FILE #357.9501 ; 10/15/04
+IBDX952 ; COMPILED XREF FOR FILE #357.9501 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX953.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX953.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX953.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX953 ; COMPILED XREF FOR FILE #357.951 ; 10/15/04
+IBDX953 ; COMPILED XREF FOR FILE #357.951 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX954.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX954.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX954.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX954 ; COMPILED XREF FOR FILE #357.9511 ; 10/15/04
+IBDX954 ; COMPILED XREF FOR FILE #357.9511 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX955.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX955.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX955.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX955 ; COMPILED XREF FOR FILE #357.952 ; 10/15/04
+IBDX955 ; COMPILED XREF FOR FILE #357.952 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX956.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX956.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX956.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX956 ; COMPILED XREF FOR FILE #357.953 ; 10/15/04
+IBDX956 ; COMPILED XREF FOR FILE #357.953 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX957.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX957.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX957.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX957 ; COMPILED XREF FOR FILE #357.95 ; 10/15/04
+IBDX957 ; COMPILED XREF FOR FILE #357.95 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX958.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX958.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX958.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX958 ; COMPILED XREF FOR FILE #357.9501 ; 10/15/04
+IBDX958 ; COMPILED XREF FOR FILE #357.9501 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX959.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX959.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDX959.m	(revision 636)
@@ -1,3 +1,3 @@
-IBDX959 ; COMPILED XREF FOR FILE #357.951 ; 10/15/04
+IBDX959 ; COMPILED XREF FOR FILE #357.951 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7QRY2.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7QRY2.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7QRY2.m	(revision 636)
@@ -1,4 +1,4 @@
-LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ; 12/10/03 10:39am
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,69**;Sep 27, 1994
+LA7QRY2 ;DALOI/JMC - Lab HL7 Query Utility ;1/30/07  19:05
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**46,69,73**;Sep 27, 1994;Build 7
  ;
  Q
@@ -9,16 +9,13 @@
  ;
  S (DFN,LRDFN)="",LA7PTYP=0
+ ; VOE changes, Use HRN cross reference, Daou;;June 8,2005
+ S LA7X=$O(^AUPNPAT("D",LA7PTID,""))
+ I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1
  ;
- ; SSN passed as patient identifier
- I LA7PTID?9N.1A D
- . S LA7PTYP=1
- . S LA7X=$O(^DPT("SSN",LA7PTID,0))
- . I LA7X>0 D SETDFN(LA7X)
+ ; See if SSN passed as patient identifier
+ I DFN'>0 S LA7X=$O(^DPT("SSN",LA7PTID,0)) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=1
  ;
  ; MPI/ICN (integration control number) passed as patient identifier
- I LA7PTID?10N1"V"6N D
- . S LA7PTYP=2
- . S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V"))
- . I LA7X>0 D SETDFN(LA7X)
+ I DFN'>0 S LA7X=$$GETDFN^MPIF001($P(LA7PTID,"V")) I LA7X>0 D SETDFN(LA7X) S LA7PTYP=2
  ;
  ; If no patient identified/no laboratory record - return exception message
Index: FOIAVistA/tag/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VORM1.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VORM1.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_LAB_INSTRUMENTS-LA/LA7VORM1.m	(revision 636)
@@ -1,4 +1,20 @@
-LA7VORM1 ;DALOI/DLR - LAB ORM (Order) message builder ; 12-12-96
- ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,46,61,64**;Sep 27, 1994
+LA7VORM1 ;DALOI/DLR - LAB ORM (Order) message builder ;1/27/07  12:25
+ ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,51,46,61,64,73**;Sep 27, 1994;Build 7
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  ;
 BUILD(LA7628) ;
@@ -6,4 +22,5 @@
  ;
  N LA7101,LA762801,LA7629,LA7NVAF,LA7PIDSN,LA7X,ECNT,GBL,SHP,SHPC,SITE,ORUID,NTST
+ N LDATE,LDATE2
  ;
  I $G(LA7628)<1!('$D(^LAHM(62.8,+$G(LA7628),0))) D  Q
@@ -11,4 +28,6 @@
  . D EXIT
  ;
+ S LDATE2=$P(^LAHM(62.8,LA7628,0),"-",2)
+ S LDATE=($E(LDATE2,1,4)-1700)_$E(LDATE2,5,8)
  S GBL="^TMP(""HLS"","_$J_")",ECNT=1
  S LA7628(0)=$G(^LAHM(62.8,LA7628,0))
@@ -64,10 +83,11 @@
  S (LRDFN,LRI,LA7PIDSN)=0
  F  S LRDFN=$O(^TMP("LA7628",$J,LRDFN)) Q:'LRDFN  D  Q:$G(HL)
- . N LA7PID,LA7PV1
+ . N LA7PID,LA7PV1,ORNUM
  . I LA7SMSG=1 D STARTMSG Q:$G(HL)
- . I LA7SMSG<2 D PID,PV1
+ . I LA7SMSG<2 D PID,PV1,IN1^LA7VORM4
  . S LA7UID=""
  . F  S LA7UID=$O(^TMP("LA7628",$J,LRDFN,LA7UID)) Q:LA7UID=""  D
- . . N LA76802,LA7ORC,X
+ . . N LA76802,LA7ORC,X,ORCCHK,DGCHK
+ . . S ORCCHK="",DGCHK=""
  . . S X=$Q(^LRO(68,"C",LA7UID))
  . . I $QS(X,3)'=LA7UID Q
@@ -76,5 +96,7 @@
  . . S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,0))
  . . S LA76802(5)=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,I,0))
- . . I LA7SMSG=2 D STARTMSG Q:$G(HL)  D PID,PV1
+ . . ;check for VOE before inserting insurance
+ . . I DUZ("AG")="E",LA7SMSG=2 D STARTMSG Q:$G(HL)  D PID,PV1,IN1^LA7VORM4
+ . . I DUZ("AG")'="E",LA7SMSG=2 D STARTMSG Q:$G(HL)  D PID,PV1
  . . S (LA7OBRSN,LA762801)=0
  . . F  S LA762801=$O(^TMP("LA7628",$J,LRDFN,LA7UID,LA762801)) Q:'LA762801  D
@@ -82,5 +104,15 @@
  . . . F I=0,.1,1,2,5 S LA762801(I)=$G(^LAHM(62.8,LA7628,10,LA762801,I))
  . . . I $$CHKTST^LA7SMU(LA7628,LA762801)'=0 Q  ;deleted accession
- . . . D ORC,OBR^LA7VORM3,OBX^LA7VORM3
+ . . . ; check for VOE to prepare for Diagnosis codes.
+ . . . I DUZ("AG")="E" D  ; check for VOE
+ . . . . S ITEMNUM=0
+ . . . . F  S ITEMNUM=ITEMNUM+1 Q:ITEMNUM>$P(^LRO(69,LDATE,1,0),"^",4)  D
+ . . . . . I LRDFN=$P(^LRO(69,LDATE,1,ITEMNUM,0),"^") S ORNUM=$P(^LRO(69,LDATE,1,ITEMNUM,0),"^",11)
+ . . . . I ORCCHK'=1 D ORC S ORCCHK=1
+ . . . . D OBR^LA7VORM3,OBX^LA7VORM3
+ . . . E  D  ; not VOE
+ . . . . D ORC,OBR^LA7VORM3,OBX^LA7VORM3
+ . . ; check for VOE before inserting Diagnosis code
+ . . I DUZ("AG")="E",DGCHK'=1 D DG1^LA7VORM4(ORNUM) S DGCHK=1
  . . I LA7SMSG=2 D BLG,SENDMSG
  . I LA7SMSG<2 D BLG
@@ -97,4 +129,5 @@
  K LRAA,LRACC,LRAD,LRAN,LRDFN,LRI
  K LTST,NLT,NLTIEN,PCNT,RUID,SNIEN,TIEN,X,Y,LA
+ K ORCCHK,DGCHK,LDATE,LDATE2
  D KVAR^LRX
  I $D(ZTQUEUED) S ZTREQ="@"
@@ -228,5 +261,4 @@
  Q
  ;
- ;
 BLG ; Billing segment
  ;
Index: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -6,12 +6,5 @@
  D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO
  W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
- W ?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY,"  ",STATE,"  ",ZIP,?48,"Bus Phone: ",BUSPHON,!   ;I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT  ;DVBA/126 comment off this code
- I $D(^DPT(DFN,.121)) I $D(DTT) D    ;DVBA/126
- .Q:$P(DTT,U,9)=""!($P(DTT,U,9)="N")
- .I $P(DTT,U,7)'="" Q:$P(DTT,U,7)>DT
- .I $P(DTT,U,8)'="" Q:$P(DTT,U,8)<DT
- .W !?2,"Temporary Address: ",TAD1,! W:TAD2]"" ?21,TAD2,! W:TAD3]"" ?21,TAD3,!
- .W ?2,"City,State,Zip+4: ",?48,"Temporary Phone: ",!?5,TCITY,"  ",TST,"  ",TZIP,?51,TPHONE,!
- I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT  ;DVBA/126
+ W !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY,"  ",STATE,"  ",ZIP,?48,"Bus Phone: ",BUSPHON,! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
  W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,!
  F LINE=1:1:80 W "="
@@ -37,5 +30,5 @@
  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
Index: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPR1.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPR1.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPR1.m	(revision 636)
@@ -1,9 +1,26 @@
 DVBCRPR1 ;ALBANY-ISC/GTS-REPRINT C&P REPORT CONTINUED ;4/28/93
- ;;2.7;AMIE;**2,119**;Apr 10, 1995;Build 10
+ ;;2.7;AMIE;**2,119**;Apr 10, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ;  ** Entry points called only from DVBCRPRT **
  ;  ** All TAGS are entry points **
 HDR S PG=PG+1
- I +$G(DVBGUI)&&(PG>1) Q
+ I +$G(DVBGUI)&(PG>1) Q
  I PG>1 D HDR3^DVBCUTL2 Q
  S:ZPR'="E" TOTTIME=$$PROCDAY^DVBCUTL2(DA(1))
Index: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPRT.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPRT.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCRPRT.m	(revision 636)
@@ -1,4 +1,21 @@
 DVBCRPRT ;ALB/GTS-557/THM-REPRINT C&P REPORT ; 5/17/91  10:28 AM
- ;;2.7;AMIE;**31,42,119**;Apr 10, 1995;Build 10
+ ;;2.7;AMIE;**31,42,119**;Apr 10, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ; ** DVBCRPRT is called from DVBCRPON only **
@@ -25,5 +42,5 @@
         .I $Y>(IOSL-9) D HDR^DVBCRPR1
  I '+$G(DVBGUI) D
- .I $Y>(IOSL-9) D UP^DVBCRPR1,NEXT,HDR^DVBCRPR1 W:$O(^DVB(396.4,OLDA,"RES",LINE))]""&&('+$G(DVBGUI)) !!,"Exam Results Continued",!!
+ .I $Y>(IOSL-9) D UP^DVBCRPR1,NEXT,HDR^DVBCRPR1 W:$O(^DVB(396.4,OLDA,"RES",LINE))]""&('+$G(DVBGUI)) !!,"Exam Results Continued",!!
  Q
 GO ;  ** An external entry point called from DVBCRPON **
Index: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m	(revision 636)
@@ -1,4 +1,4 @@
 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,!!
@@ -6,5 +6,5 @@
  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
  ;
@@ -28,11 +28,4 @@
  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
Index: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCWNS5.m
===================================================================
--- FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCWNS5.m	(revision 631)
+++ FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCWNS5.m	(revision 636)
@@ -48,6 +48,6 @@
         ;; 
         ;;       1.      Inspection: spine, limbs, posture and gait, position of the
-        ;;	       head, curvatures of the spine, symmetry in appearance, symmetry
-        ;;	       and rhythm of spinal motion.
+        ;;        head, curvatures of the spine, symmetry in appearance, symmetry
+        ;;        and rhythm of spinal motion.
         ;;
         ;;       2.      Range of motion
@@ -56,10 +56,10 @@
         ;;
         ;;               The reproducibility of an individual's range of motion is one
-        ;;	       indicator of optimum effort. Pain, fear of injury, disuse or
-        ;;	       neuromuscular inhibition may limit mobility by decreasing the
-        ;;	       individual's effort. If range of motion measurements fail to
-        ;;	       match known pathology, please repeat the measurements.
-        ;;	       (Reference: Guides to the Evaluation of Permanent Impairment,
-        ;;	       Fifth Edition, 2001, page 399).
+        ;;        indicator of optimum effort. Pain, fear of injury, disuse or
+        ;;        neuromuscular inhibition may limit mobility by decreasing the
+        ;;        individual's effort. If range of motion measurements fail to
+        ;;        match known pathology, please repeat the measurements.
+        ;;        (Reference: Guides to the Evaluation of Permanent Impairment,
+        ;;        Fifth Edition, 2001, page 399).
         ;; 
         ;;           i. Using a goniometer, measure and report the range of motion in
@@ -135,10 +135,10 @@
         ;;              motion for the thoracolumbar spine as a unit are as follows:
         ;;
-        ;;		-Forward flexion: 0 to 90 degrees 
-        ;;		-Extension: 0 to 30 degrees 
-        ;;		-Left Lateral Flexion: 0 to 30 degrees 
-        ;;		-Right Lateral Flexion: 0 to 30 degrees 
-        ;;		-Left Lateral Rotation: 0 to 30 degrees 
-        ;;		-Right Lateral Rotation: 0 to 30 degrees
+        ;;  -Forward flexion: 0 to 90 degrees 
+        ;;  -Extension: 0 to 30 degrees 
+        ;;  -Left Lateral Flexion: 0 to 30 degrees 
+        ;;  -Right Lateral Flexion: 0 to 30 degrees 
+        ;;  -Left Lateral Rotation: 0 to 30 degrees 
+        ;;  -Right Lateral Rotation: 0 to 30 degrees
         ;; 
         ;;There may be a situation where an individual's range of motion is reduced, but 
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBGEN1.m	(revision 636)
@@ -1,5 +1,4 @@
-ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;05/10/07
- ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ALPBGEN1 ;SFVAMC/JC - Parse and File HL7 PMU messages ;04/30/2003  07:59
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  Q
  ;
@@ -45,5 +44,5 @@
  ;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
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBINP.m	(revision 636)
@@ -1,5 +1,4 @@
 ALPBINP ;OIFO-DALLAS/SED/KC/MW  BCMA - BCBU INPT TO HL7 ;5/2/2002
- ;;3.0;BAR CODE MED ADMIN;**8,37**;May 2007;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  ;This routine will intercept the HL7 message that it sent from Pharmacy
  ;to CPRS to update order information. The message is then parsed and 
@@ -46,5 +45,4 @@
  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
@@ -67,5 +65,5 @@
  ;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
@@ -144,5 +142,5 @@
  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")
@@ -161,5 +159,5 @@
  ;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)
@@ -202,5 +200,5 @@
  ;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")
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBPWRD.m	(revision 636)
@@ -1,5 +1,4 @@
 ALPBPWRD ;OIFO-DALLAS MW,SED,KC-PRINT 3-DAY MAR BCMA BCBU REPORT FOR A SELECTED WARD ;01/01/03
- ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  ; 
  ; NOTE: this routine is designed for hard-copy output.
@@ -144,7 +143,6 @@
  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
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/ALPBUTL1.m	(revision 636)
@@ -1,5 +1,4 @@
 ALPBUTL1 ;OIFO-DALLAS MW,SED,KC-BCBU BACKUP REPORT FUNCTIONS AND UTILITIES  ;01/01/03
- ;;3.0;BAR CODE MED ADMIN;**8,37**;Mar 2004;Build 10
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
  ;
  ; Reference/IA
@@ -181,5 +180,5 @@
  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 ""
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -71,5 +71,5 @@
  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
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBO1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSBO1 ;BIRMINGHAM/EFC-BCMA OUTPUTS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**4,13,32,2**;Mar 2004;Build 22
+ ;;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
@@ -9,9 +9,9 @@
  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)>0:DILOCKTM,1:3)
+ L +(^PSB(53.69,0)):0
  E  S RESULTS(0)="-1^Request Log Locked" Q
  ; Generate Unique Entry and Create
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBOMH1.m	(revision 636)
@@ -1,5 +1,23 @@
-PSBOMH1 ;BIRMINGHAM/EFC-MAH ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**6,3,9,11,26,38**;Mar 2004;Build 8
+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
  ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ; Reference/IA
@@ -123,5 +141,12 @@
  I PSBGA'=1 S PSBTMP(10000000-$P(PSBMLA(0),U,6),"A")=$P(PSBMLA(0),U,6)_U_$$INITIAL^PSBRPC2($P(PSBMLA(0),U,7))
  S PSBQRY="PSBTMP",PSBCNT=1 F  S PSBQRY=$Q(@PSBQRY) Q:PSBQRY=""  D  ; does comment go with action
- .S PSBPQRY=$Q(@PSBQRY,-1)
+ .;
+ .;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ .;
+ .;S PSBPQRY=$Q(@PSBQRY,-1)
+ .S PSBPQRY=$$Q^VWUTIL($NA(@PSBQRY),-1)
+ .;
+ .;END CHANGE
+ .;
  .I PSBPQRY="" S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; no prev action
  .I $QS(PSBPQRY,2)="C"  S PSBTAR(PSBCNT)=@PSBQRY,PSBCNT=PSBCNT+1 Q  ; prev line = comment
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBPOIV.m	(revision 636)
@@ -1,11 +1,11 @@
 PSBPOIV ;BIRMINGHAM/EFC-IV PARAMETER VALIDATION ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**2**;Mar 2004;Build 22
- ;;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ;;3.0;BAR CODE MED ADMIN;;Mar 2004
  ;
  ; Reference/IA
+ ; ^DIC(42/1377
  ; ^DIC(42/2440
+ ; EN^PSJCBMA1/2829
  ; EN^PSJBCMA2/2830
- ; VADPT/10061
- ;
+ ; DIQ(2/10035
  ;
 EN(PSBDFN,PSBORD) ;
@@ -16,5 +16,5 @@
  ; 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,""))
@@ -22,7 +22,7 @@
  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.
Index: FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m
===================================================================
--- FOIAVistA/trunk/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m	(revision 631)
+++ FOIAVistA/tag/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBRPC2.m	(revision 636)
@@ -1,5 +1,23 @@
-PSBRPC2 ;BIRMINGHAM/EFC-BCMA RPC BROKER CALLS ;Mar 2004
- ;;3.0;BAR CODE MED ADMIN;**6,3,16,32**;Mar 2004;Build 32
+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
  ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ; Reference/IA
@@ -54,5 +72,5 @@
  Q
  ;
-BAGDTL(RESULTS,PSBUID,PSBORD)  ; bag detail
+BAGDTL(RESULTS,PSBUID,PSBORD) ; bag detail
  I $G(DFN)="" S DFN=+PSBUID
  S (PSBIEN,X)="" F  S X=$O(^PSB(53.79,"AUID",DFN,X)) Q:X=""  S:$D(^PSB(53.79,"AUID",DFN,X,PSBUID)) PSBIEN=$O(^PSB(53.79,"AUID",DFN,X,PSBUID,"")) Q:PSBIEN]""
@@ -85,5 +103,5 @@
 INITIAL(PSBDUZ) ;
  Q $$GET1^DIQ(200,PSBDUZ,"INITIAL")
-SCANMED(RESULTS,PSBDIEN,PSBTAB)  ; Lookup Medication
+SCANMED(RESULTS,PSBDIEN,PSBTAB) ; Lookup Medication
  ;
  ; RPC: PSB SCANMED
Index: FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m
===================================================================
--- FOIAVistA/trunk/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m	(revision 631)
+++ FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTCE.m	(revision 636)
@@ -1,4 +1,4 @@
 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 ;
@@ -22,5 +22,5 @@
  . 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
Index: FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m
===================================================================
--- FOIAVistA/trunk/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m	(revision 631)
+++ FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTCR.m	(revision 636)
@@ -1,4 +1,4 @@
 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)
@@ -37,6 +37,5 @@
  S X=$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM10=X
  S X=DGBTM6*DGBTM7+$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR("M"),"^",5) D COMMA^%DTC S DGBTM11=X
- S X2="3$",X=DGBTM7 D COMMA^%DTC S DGBTM7=X
- S X2="2$"  ;Reset edit mask to 2 decimal positions for rest of report
+ S X=DGBTM7 D COMMA^%DTC S DGBTM7=X
  S X=$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM12=X
  S X=$P(DGBTVAR("M"),"^",4)+$P(DGBTVAR(0),"^",8) D COMMA^%DTC S DGBTM13=X
Index: FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m
===================================================================
--- FOIAVistA/trunk/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m	(revision 631)
+++ FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE.m	(revision 636)
@@ -1,4 +1,4 @@
 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 ;
@@ -26,5 +26,5 @@
 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
Index: FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m
===================================================================
--- FOIAVistA/trunk/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m	(revision 631)
+++ FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTEE1.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -53,5 +53,5 @@
  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
Index: FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTEF1.m
===================================================================
--- FOIAVistA/trunk/r/BENEFICIARY_TRAVEL-DGBT/DGBTEF1.m	(revision 631)
+++ FOIAVistA/tag/r/BENEFICIARY_TRAVEL-DGBT/DGBTEF1.m	(revision 636)
@@ -1,11 +1,9 @@
 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
Index: FOIAVistA/tag/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_CASE_REGISTRIES-ROR/RORHL09.m	(revision 636)
@@ -1,7 +1,4 @@
 RORHL09 ;HOIFO/BH - HL7 OUTPATIENT DATA: PV1,OBR,OBX ; 3/13/06 9:24am
- ;;1.5;CLINICAL CASE REGISTRIES;**1,5**;Feb 17, 2006;Build 10
- ;
- ; 11/29/2007 BAY/KAM ROR*1.5*5 Rem Call 218601 Correct Outpatient
- ;                              CPTs not transmitting to the AAC
+ ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
  ;
  ; This routine uses the following IAs:
@@ -164,12 +161,9 @@
  . ;---
  . 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
- . ;---
- . I PRV>0 D
- .. S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
- .. I $G(DIERR)  D  S ERRCNT=ERRCNT+1
- ... D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
- . E  S PRV=""
- . ;----------> End of changes for 218601
+ . Q:PRV'>0
+ . ;---
+ . S $P(PRV,RORCS,13)=$$GET1^DIQ(200,PRV_",",53.5,"E",,"RORMSG")
+ . I $G(DIERR)  D  S ERRCNT=ERRCNT+1
+ . . D DBS^RORERR("RORMSG",-99,,RORDFN,200,+PRV_",")
  . ;---
  . D SETOBX(OID,PROC,PRV)
Index: FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEVPRG.m	(revision 636)
@@ -1,4 +1,4 @@
 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**;30 Apr 99;Build 3
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**3,12,19,32,35,43,44**;30 Apr 99;Build 8
  ;
 MAIN ;
@@ -108,9 +108,9 @@
  ;K ETYPE,CNT,IEN,IEN2,NUM,X,Y
  ;Q
-PRGDUP ;Purge Duplicate Entries; retain most recent for all except types.
- ;**50 through remainder of module.
+PRGDUP ; Purge Duplicate Entries; retain most recent for all types except 234.
  S EXCTYP="",CNT=0
  K ^TMP("RGEVDUP",$J)
  F  S EXCTYP=$O(^RGHL7(991.1,"ADFN",EXCTYP)) Q:'EXCTYP  D
+ . I EXCTYP=234 Q  ;**44 process 234s separately below
  . S RGDFN=""
  . F  S RGDFN=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN)) Q:'RGDFN  D
@@ -119,27 +119,69 @@
  ... S IEN2=0
  ... F  S IEN2=$O(^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2)) Q:'IEN2  D
- .... I $P($G(^RGHL7(991.1,IEN,1,IEN2,0)),"^",5)=1 K ^RGHL7(991.1,"ADFN",EXCTYP,RGDFN,IEN,IEN2) Q  ;exception processed
- .... S EXCDT=$P($G(^RGHL7(991.1,IEN,0)),"^",3) ;incoming date
+ .... S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
  .... I '$D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D  Q
  ..... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
- .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D  ;duplicate exists; compare incoming to previous.
+ .... I $D(^TMP("RGEVDUP",$J,RGDFN,EXCTYP)) D
  ..... S OLDNODE=^TMP("RGEVDUP",$J,RGDFN,EXCTYP)
- ..... S OLDDT=$P(OLDNODE,"^"),OLDIEN=$P(OLDNODE,"^",2),OLDIEN2=$P(OLDNODE,"^",3)
- ..... I EXCDT>OLDDT D  Q  ;incoming date greater than previous? purge old, keep new.
+ ..... S OLDDT=$P(OLDNODE,"^")
+ ..... I EXCDT>OLDDT D  Q
  ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
- ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=OLDIEN D ^DIK K DIK,DA
- ...... I NUM>1 D
- ....... S DA(1)=OLDIEN,DA=OLDIEN2
+ ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=$P(OLDNODE,"^",2) D ^DIK K DIK,DA
+ ...... E  I NUM>1 D
+ ....... S DA(1)=$P(OLDNODE,"^",2),DA=$P(OLDNODE,"^",3)
  ....... S DIK="^RGHL7(991.1,"_DA(1)_",1," D ^DIK K DIK,DA
+ ...... S CNT=CNT+1
  ...... S ^TMP("RGEVDUP",$J,RGDFN,EXCTYP)=EXCDT_"^"_IEN_"^"_IEN2
- ..... ;
- ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D  ;previous date greater or equal incoming? purge new, keep old.
+ ..... I OLDDT>EXCDT!(OLDDT=EXCDT) D
  ...... S NUM="" S NUM=$P(^RGHL7(991.1,IEN,1,0),"^",4)
- ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA
- ...... I NUM>1 D DEL
- ...... ;
- K CNT,EXCDT,EXCTYP,IEN,IEN2,NUM,OLDDT,OLDIEN,OLDIEN2,OLDNODE,RGDFN,RGDT,^TMP("RGEVDUP")
- Q
- ;
+ ...... I NUM=1 S DIK="^RGHL7(991.1,",DA=IEN D ^DIK K DIK,DA S CNT=CNT+1
+ ...... E  I NUM>1 D DEL
+ ; W !,CNT_" Duplicate entries"
+ ;Process PRIMARY VIEW REJECT (234) duplicates; purge if for SAME day.
+ ;**44 through remainder of module.
+ K ^TMP("RGDFNDT",$J) S RGDFN=""
+ F  S RGDFN=$O(^RGHL7(991.1,"ADFN",234,RGDFN)) Q:'RGDFN  D
+ .S IEN=0
+ .F  S IEN=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN)) Q:'IEN  D
+ ..S IEN2=0
+ ..F  S IEN2=$O(^RGHL7(991.1,"ADFN",234,RGDFN,IEN,IEN2)) Q:'IEN2  D
+ ...S EXCDT=$P(^RGHL7(991.1,IEN,0),"^",3)
+ ...;How many for each DFN? Store in ^TMP("RGDFNDT")
+ ...I '$D(^TMP("RGDFNDT",$J,RGDFN)) S ^TMP("RGDFNDT",$J,RGDFN)=0
+ ...I $D(^TMP("RGDFNDT",$J,RGDFN)) D
+ ....S ^TMP("RGDFNDT",$J,RGDFN)=^TMP("RGDFNDT",$J,RGDFN)+1
+ ....S ^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)=$P(EXCDT,".") ;date only/no time
+ ;If RGDFN has more than 1 exception, see if any are for same DAY.
+ ;Process the ^TMP("RGDFNDT",$J global to build LOC array.
+ I $D(^TMP("RGDFNDT",$J)) D
+ .S RGDFN=""
+ .F  S RGDFN=$O(^TMP("RGDFNDT",$J,RGDFN)) Q:'RGDFN  D
+ ..;If only one 234 exception for DFN ignore it.
+ ..I ^TMP("RGDFNDT",$J,RGDFN)=1 Q
+ ..;More than one for this DFN?  How many for same day?
+ ..S IEN=0 K LOC
+ ..F  S IEN=$O(^TMP("RGDFNDT",$J,RGDFN,IEN)) Q:'IEN  D
+ ...S (IEN2,VAL)=0
+ ...F  S IEN2=$O(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2)) Q:'IEN2  D
+ ....S VAL=$P(^TMP("RGDFNDT",$J,RGDFN,IEN,IEN2),"^")
+ ....I '$D(LOC(VAL)) S LOC(VAL)=0
+ ....I $D(LOC(VAL)) D
+ .....S LOC(VAL)=LOC(VAL)+1
+ .....S LOC(VAL,IEN,IEN2)=""
+ ..;Process the LOC array; contains numbers / day / DFN.
+ ..;If only 1 exception / day, keep it.
+ ..S RGDT=0 K CTR,TOT
+ ..F  S RGDT=$O(LOC(RGDT)) Q:'RGDT  D
+ ...S TOT=LOC(RGDT)
+ ...I TOT=1 K TOT Q  ;only 1.
+ ...;More than 1, delete all except 1.
+ ...S TOT=TOT-1 ;leave 1; doesn't matter which - all are same day.
+ ...S IEN=0,CTR=0
+ ...F  S IEN=$O(LOC(RGDT,IEN)) Q:'IEN  D
+ ....I CTR=TOT Q
+ ....S CTR=CTR+1,IEN2=0
+ ....F  S IEN2=$O(LOC(RGDT,IEN,IEN2)) Q:'IEN2  D DEL ;delete entry
+ K CNT,CTR,EXCDT,IEN,IEN2,LOC,NUM,OLDDT,OLDNODE,RGDFN,RGDT,TOT,VAL,^TMP("RGDFNDT")
+ Q
 PRGZZ ;Purge if name field is null (incomplete record)
  ;Purge if -9 node exists, this indicates the record has been merged.
Index: FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX06.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -18,7 +18,7 @@
  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
@@ -51,7 +51,7 @@
  ;
 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
Index: FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_INFO_RESOURCE_NETWORK-MRF-RGE--RG--RGED--RGUT--RGWB/RGEX07.m	(revision 636)
@@ -1,4 +1,4 @@
 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
@@ -19,7 +19,7 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDAPI.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDAPI.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDAPI.m	(revision 636)
@@ -1,9 +1,9 @@
 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.
  ;
@@ -138,15 +138,13 @@
  ;  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
  ;
@@ -161,5 +159,5 @@
  ;  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."
@@ -169,20 +167,9 @@
  I '$G(MDNTIU) Q "0^No New Reassigned TIU IEN."
  S (MDD,MDCHK,MDREAS,MDTRAN)="",MDPPR=0 K ^TMP("MDTMP",$J)
- S MDTRAN=$O(^MDD(702,"ATIU",MDANOTE,0)) I +MDTRAN S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_"," D
+ F  S MDTRAN=$O(^MDD(702,"ACON",MDOLDC,MDTRAN)) Q:'MDTRAN  D
+ .S MDCHK=$G(^MDD(702,MDTRAN,0)),MDTRANI=MDTRAN_","
  .I $P(MDCHK,U,5)=MDOLDC&($P(MDCHK,U,6)=MDANOTE) D
- ..S MDFDA(702,+MDTRAN_",",.06)=""
- ..D FILE^DIE("","MDFDA") K MDFDA
- S MDGBL=$NA(^MDD(702.001,"PK",MDANOTE))
- F  S MDGBL=$Q(@MDGBL) Q:MDGBL=""  Q:$QS(MDGBL,2)'="PK"!($QS(MDGBL,3)'=MDANOTE)  S MDN=$QS(MDGBL,6) N DA,DIK S DA=+MDN,DIK="^MDD(702.001," D ^DIK
- S MDMULN=+$O(^MDD(702.001,"ASTUDY",+MDTRAN,0))
- I '+MDMULN I +MDTRAN N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
- D NOW^%DTC S MDD=% S MDTRANI=$O(^MDD(702,"ACON",MDNEWC,0))
- S MDREAS=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
- I +MDTRANI&(MDNDFN=+$G(^MDD(702,+MDTRANI,0))) D
- .S MDPPR=$P($G(^MDD(702,+MDTRANI,0)),"^",4) Q:'MDPPR
- .S MDNEWV=$$GETVSTR^MDRPCOT1(MDNDFN,MDREAS,MDPPR,MDD)
- .S MDFDA(702,+MDTRANI_",",.06)=MDNTIU
- .S MDFDA(702,"+1,",.07)=$P(MDNEWV,";",3)_";"_$P(MDNEWV,";",2)_";"_$P(MDNEWV,";")
- .D FILE^DIE("","MDFDA") K MDFDA
+ ..S:'MDPPR MDPPR=$P(MDCHK,U,4)
+ ..N DA,DIK S DA=+MDTRAN,DIK="^MDD(702," D ^DIK
  I 'MDPPR D
  .D CPLIST^GMRCCP(MDNDFN,,$NA(^TMP("MDTMP",$J)))
@@ -190,5 +177,7 @@
  .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
@@ -200,5 +189,5 @@
  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
  ;
@@ -210,30 +199,2 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7A.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7A.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7A.m	(revision 636)
@@ -1,9 +1,8 @@
-MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ;9/17/07  08:17
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+MDHL7A ; HOIFO/WAA - Routine to Decode HL7 for CP ; [05-07-2001 10:38]
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference DBIA #10035 [Supported] for DPT calls.
  ; Reference DBIA #10106 [Supported] for HLFNC calls.
  ; Reference DBIA #10062 [Supported] for VADPT6 calls.
- ; Reference DBIA #2701 [Supported] for MPIF001 calls
- ; Reference DBIA #10096 [Supported] for ^%ZOSF calls
+ ; Reference DBIA #2701 [Supported] for MPIF001 Calls
 EN ; [Procedure] Entry Point for Message Array in MSG
  N %,BID,CODE,CPT,DA,DATE,DFN,DIK,DLCO,DTO,DZ,ERRTX,EXAM,EXE,MDFLAG,FIL
@@ -13,23 +12,13 @@
  N ECODE,MDIEN,MDOBX,NUMZ,PNAM,ZCODE,MDDEV,MDD702,DEVNAME,DEVIEN,MDQFLG
  N MDIORD
- K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7"),^TMP($J,"MDHL7A1")
+ K ^TMP($J,"MDHL7A"),^TMP($J,"MDHL7")
  S MDFLAG=0,MDERROR=0,MDQFLG=0
- Q:$G(HLMTIENS)=""
- S ^TMP($J,"MDHL7A1")=""
- S HLREST="^TMP($J,""MDHL7A1"")"
- S X=$$MSGIEN^MDHL7U3(HLMTIENS,HLREST) ; This code is to convert the HL7 Message **6**
- I $P(X,U)=0 D  Q
- . S DEVIEN=0,ECODE=0
- . S ERRTX=$P(X,U,2)
- . D ^MDHL7X
- . Q
- I $P(X,U)=1 D XVERT^MDHL7U3("MDHL7A1","MDHL7A")
- K HLNODE,^TMP($J,"MDHL7A1")
+ F I=1:1 X HLNEXT Q:MDQFLG  S ^TMP($J,"MDHL7A",I)=$TR(HLNODE,$C(10),""),J=0 S:HLQUIT<1 MDQFLG=1 F  S J=$O(HLNODE(J)) Q:J<1  S ^TMP($J,"MDHL7A",I,J)=$TR(HLNODE(J),$C(10),"")
+ K HLNODE
  ;
 EN2 ; [Procedure] No Description
- S (DEVIEN,DEVNAME)="",I=0
+ S (DEVIEN,DEVNAME)=""
  F I=1:1 S X=$G(^TMP($J,"MDHL7A",I)) Q:X=""  Q:$E(X,1,3)="OBX"  D
  . S:$E(X,1,3)="MSH" DEVNAME=$P(X,"|",4)
- . I DEVNAME="",HLREC("SFN")'="" S DEVNAME=HLREC("SFN")
  . I $E(X,1,3)="MSH",DEVNAME'="Instrument Manager" S DEVIEN=$O(^MDS(702.09,"B",DEVNAME,0))
  . I $E(X,1,3)="OBR" D
@@ -58,6 +47,9 @@
  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)
@@ -104,5 +96,4 @@
  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)
@@ -110,5 +101,4 @@
  ;  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,",","-")
@@ -119,6 +109,4 @@
  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
  ;
@@ -126,5 +114,4 @@
  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
@@ -154,13 +141,14 @@
  ;
 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
@@ -171,8 +159,5 @@
  D UPDATE^DIE("","MDFDA","MDIEN")
  L -(^MDD(703.1,"B"))
- I $G(MDIEN(1))>0 D  Q MDIEN(1)_U_NEWID
- . S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0"
- . S MDNO=$$NTIU^MDRPCW1(+MDD702)
- . Q
+ I $G(MDIEN(1))>0 S ^MDD(703.1,MDIEN(1),.1,0)="^703.11S^0^0" Q MDIEN(1)_U_NEWID
  ; ^^--- Create Subfile and quit
  Q "-1"  ; Unable to create file
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7MCA.m	(revision 636)
@@ -1,8 +1,7 @@
-MDHL7MCA ; HOIFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
+MDHL7MCA ; HIRMFO/REL-Routine to Decode HL7 for MEDICINE ; [05-07-2001 10:38]
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference DBIA #10035 for DPT calls.
  ; Reference DBIA #10062 for VADPT calls.
  ; Reference DBIA #10106 for HL7 calls.
- ; Reference DBIA #10096 for ^%ZOSF calls.
 EN ; Entry Point for Message Array in MSG
  N MSG
@@ -38,4 +37,5 @@
  ;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
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7U3.m	(revision 636)
@@ -1,46 +1,5 @@
 MDHL7U3 ; HOIFO/WAA -Utilities for CP to process HL7 messages  ; 7/26/00
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
- ; Reference DBIA #2729 [Supported]  for XMXPAI
+ ;;1.0;CLINICAL PROCEDURES;;Apr 01, 2004
  ; Reference DBIA #4262 [Supported] for HL7 call.
- ; Reference DBIA #3273 [Subscription] for HL7 call.
- ; Reference DBIA #10138 [Supported] for HL7 call.
- ; Reference DBIA #3990 [Supported] for ICDCODE call
- ; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference
- ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
- ; Reference DBIA #10082 [Supported] for ^ICD9 reference
- ; Reference DBIA #10111 [Supported] for FILE 3.8 call
- ; Reference DBIA #10103 [Supported] for XLFDT call
- ;
-HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient.
- N X
- S X="1^"
- D
- . N Y
- . I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q
- . I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q
- . S Y=0
- . S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file."
- . Q
- Q X
-XVERT(MDA,MDB) ; Strip out blank Lines
- Q:MDA=""
- Q:MDB=""
- Q:$G(^TMP($J,MDA,1))
- N I,CNT,CNT2,NODE,FLG
- S (CNT,I,FLG)=0
- F  S I=$O(^TMP($J,MDA,I)) Q:I<1  D
- . S NODE=$TR(^TMP($J,MDA,I),$C(10),"")
- . I NODE="" S FLG=0 Q
- . I FLG  D  Q
- . . S CNT2=CNT2+1
- . . S ^TMP($J,MDB,CNT,CNT2)=NODE
- . . Q
- . I 'FLG D  Q
- . . S CNT=CNT+1
- . . S ^TMP($J,MDB,CNT)=NODE
- . . S FLG=1,CNT2=0
- . . Q
- . Q
- Q
  ;
 PURGE(MDD7031) ;
@@ -52,161 +11,2 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7X.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDHL7X.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDHL7X.m	(revision 636)
@@ -1,4 +1,4 @@
 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.
@@ -12,8 +12,8 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOG.m	(revision 636)
@@ -1,4 +1,4 @@
 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.  
@@ -116,10 +116,4 @@
  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)
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOP.m	(revision 636)
@@ -1,6 +1,5 @@
-MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ;3/12/08  09:16
- ;;1.0;CLINICAL PROCEDURES;**4,6**;Apr 01, 2004;Build 102
+MDRPCOP ; HOIFO/DP - Object RPCs (TMDPatient) ; [01-09-2003 15:21]
+ ;;1.0;CLINICAL PROCEDURES;**4**;Apr 01, 2004;Build 3
  ; Integration Agreements:
- ; IA# 2263 [Supported] XPAR calls
  ; IA# 3027 [Supported] Calls to DGSEC4
  ; IA# 2981 [Subscription] Calls to GUI~GMRCP5
@@ -9,11 +8,13 @@
  ; 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@(...
@@ -50,12 +51,4 @@
  .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)
@@ -68,12 +61,9 @@
  ;
 GETCONS ; [Procedure] Get available consults for patient
- K ^TMP("MDTMP",$J) N MDCDT,MDDY,X1,X2,X
- S MDDY=$$GET^XPAR("SYS","MD COMPL PROC DISPLAY DAYS",1)
- S X1=DT,X2=-$S(MDDY>0:+MDDY,1:365) D C^%DTC S MDCDT=X
+ K ^TMP("MDTMP",$J)
  D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
  S MDX=0
  F  S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX  D:"saprc"[$P(^(MDX),U,4)
  .S Y="123;"_$P(^TMP("MDTMP",$J,MDX),U,5)
- .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
  .F X=2,3,4,1,6,5 S Y=Y_U_$P(^TMP("MDTMP",$J,MDX),U,X)
  .S Y=Y_U_+$O(^MDD(702,"ACON",+$P(^TMP("MDTMP",$J,MDX),U,5)))
@@ -124,33 +114,15 @@
  ;
 GETTRAN ; [Procedure] Get a patients transactions
- K ^TMP("MDTMP",$J),^TMP("MDCONL",$J) N MDCDT,MDCOM,MDMULT,MDNUM,MDREQ,MDREQDT,MDYR,X1,X2,X
- S MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1) S MDCOM=0
- I +MDNUM>0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X
- D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMP",$J)))
- S X1=DT,X2=-365 D C^%DTC S MDCDT=X
- S MDX=0 F  S MDX=$O(^TMP("MDTMP",$J,MDX)) Q:'MDX  D:"saprc"[$P(^(MDX),U,4)
- .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
- .S ^TMP("MDCONL",$J,$P($G(^TMP("MDTMP",$J,MDX)),U,5))=$P($G(^TMP("MDTMP",$J,MDX)),U,1)
- K ^TMP("MDTMP",$J)
  F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX  D
- .Q:'$$GET1^DIQ(702,MDX,.05,"I")
- .Q:$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))=""
- .S MDMULT=+$$GET1^DIQ(702,MDX,".04:.12","I")
- .S MDYR=$S(MDMULT<1:MDCOM,1:MDCDT)
- .I MDNUM Q:$$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDYR)
- .S MDREQDT="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDREQDT=$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))
- .I MDREQDT'="" S MDREQDT=$$FMTE^XLFDT(MDREQDT,"1P")
- .S MDREQ=$$GET1^DIQ(702,MDX,.04)_"  "_+MDX_"  (Consult #:"_$$GET1^DIQ(702,MDX,.05,"I")_$S(MDREQDT'="":" Requested: "_MDREQDT,1:"")_")"
- .S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_MDREQ_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991)
+ .S Z=$$GET1^DIQ(702,MDX,".04:.02","I")_U_$$GET1^DIQ(702,MDX,.04)_U_$$GET1^DIQ(702,MDX,.02,"I")_U_$$GET1^DIQ(702,MDX,.09)_U_$$GET1^DIQ(702,MDX,.11)_U_$$GET1^DIQ(702,MDX,.991)
  .S Y=$O(@RESULTS@(""),-1)+1
  .S @RESULTS@(Y)="702;"_+MDX_U_Z
  S @RESULTS@(0)=+$O(@RESULTS@(""),-1)
- K ^TMP("MDCONL",$J)
  Q
  ;
 GETVST ; [Procedure] Return list of visits
- N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,MDTDF,STI,STS,TODAY,I,J,K,XI,XE,X
- S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1),MDTDF=DFN
- S BEG=$$X2FM($$GETBEG),END=$$X2FM($$GETEND)+0.2359
+ N BEG,END,VAERR,VASD,BDT,DTM,EDT,LOC,NOW,MDQUERY,MDLST,STI,STS,TODAY,I,J,K,XI,XE,X
+ S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
+ S BEG=$$X2FM("T-200"),END=$$X2FM("T")+0.2359
  S MDLST="",MDSTOP=""
  I END>NOW D   ; get future encounters, past cancels/no-shows from VADPT
@@ -179,5 +151,5 @@
  .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
@@ -192,17 +164,10 @@
  ..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)]"")
- 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"
+ S @RESULTS@(0)=+$O(@RESULTS@(""),-1)_U_($$GET1^DIQ(2,DFN_",",.1)]"")
+ Q
+ ;
 LOGSEC ; [Procedure] Log Security
- N RES
- D NOTICE^DGSEC4(.RES,DFN,DATA,1)
- S @RESULTS@(0)=$S(+RES:"1^Logged",1:"-1^Unable to log")
+ D NOTICE^DGSEC4(.RESULTS,DFN,DATA,1)
+ S @RESULTS@(0)=$S(RESULTS:"1^Logged",1:"-1^Unable to log")
  Q
  ;
@@ -216,6 +181,56 @@
  ;
 SELECT ; [Procedure] Select patient
- ; Moved to continuation routine at MD*1.0*6 due to routine size
- D SELECT^MDRPCOP1
+ I '$D(^DPT(+$G(DFN),0))#2 S @RESULTS@(0)="-1^No such patient" Q
+ S @RESULTS@(0)="1^Required Identifiers & messages"
+ S IENS=DFN_","
+ D FILE^DID(2,,"REQUIRED IDENTIFIERS","MDIDS")
+ F MDX=0:0 S MDX=$O(MDIDS("REQUIRED IDENTIFIERS",MDX)) Q:'MDX  D
+ .S MDFLD=MDIDS("REQUIRED IDENTIFIERS",MDX,"FIELD")
+ .S MDID="$$PTID^"_$$GET1^DID(2,MDFLD,"","LABEL")
+ .S MDID=MDID_U_$$GET1^DIQ(2,IENS,MDFLD)
+ .D:MDFLD=.03
+ ..S MDID=MDID_" ("_$$GET1^DIQ(2,IENS,.033)_")"
+ ..S MDID=MDID_U_$$DOB^DPTLK1(+IENS)
+ .D:MDFLD=.09
+ ..S X=$P(MDID,U,3),X=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10)
+ ..S $P(MDID,U,3)=X,$P(MDID,U,4)=$$SSN^DPTLK1(+IENS)
+ .S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
+ S MDID="$$PTID^"_$$GET1^DID(2,.1,"","LABEL")
+ S MDID=MDID_U_$$GET1^DIQ(2,IENS,.1)
+ S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
+ S MDID="$$PTID^"_$$GET1^DID(2,.101,"","LABEL")
+ S MDID=MDID_U_$$GET1^DIQ(2,IENS,.101)
+ S @RESULTS@($O(@RESULTS@(""),-1)+1)=MDID
+ K MDRET
+ D GUIBS5A^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
+ .D ADD("$$MSGHDR^2^SAME LAST NAME AND LAST 4")
+ .S MDX=1
+ .F  S MDX=$O(MDRET(MDX)) Q:'MDX!(+$G(MDRET(MDX)))  D
+ ..D ADD($P(MDRET(MDX),U,2))
+ .D ADD(" ")
+ .S MDX=1
+ .F  S MDX=$O(MDRET(MDX)) Q:'MDX  D:+MDRET(MDX)
+ ..S MDDFN=+$P(MDRET(MDX),U,2)
+ ..D ADD($$GET1^DIQ(2,MDDFN_",",.01)_"    "_$$DOB^DPTLK1(MDDFN)_"    "_$$SSN^DPTLK1(MDDFN))
+ .D ADD(" ")
+ .D ADD("Please review carefully before continuing")
+ .D ADD("$$MSGEND")
+ K MDRET
+ D PTSEC^DGSEC4(.MDRET,DFN) D:MDRET(1)'=0
+ .D:MDRET(1)=3
+ ..D ADD("$$MSGHDR^0^CAN'T ACCESS YOUR OWN RECORD!!")
+ .D:MDRET(1)=-1
+ ..D ADD("$$MSGHDR^0^INCOMPLETE INFORMATION - CAN'T PROCEED")
+ .D:MDRET(1)=1
+ ..D ADD("$$MSGHDR^1^SENSITIVE RECORD ACCESS")
+ .D:MDRET(1)'=-1&(MDRET(1)'=3)&(MDRET(1)'=1)
+ ..D ADD("$$MSGHDR^3^SENSITIVE RECORD ACCESS")
+ .S MDX=1
+ .F  S MDX=$O(MDRET(MDX)) Q:'MDX  D ADD($TR(MDRET(MDX),"*"," "))
+ .D ADD("$$MSGEND")
+ D GUIMTD^DPTLK6(.MDRET,DFN) D:MDRET(1)=1
+ .D ADD("$$MSGHDR^1^NOTICE")
+ .F MDX=1:0 S MDX=$O(MDRET(MDX)) Q:'MDX  D ADD(MDRET(MDX))
+ .D ADD("$$MSGEND")
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_PROCEDURES-MD/MDRPCOT.m	(revision 636)
@@ -1,4 +1,4 @@
-MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;3/12/08  09:18
- ;;1.0;CLINICAL PROCEDURES;**5,6**;Apr 01, 2004;Build 102
+MDRPCOT ; HOIFO/DP/NCA - Object RPCs (TMDTransaction) ;12/5/02  15:33
+ ;;1.0;CLINICAL PROCEDURES;**5**;Apr 01, 2004;Build 1
  ; Integration Agreements:
  ; IA# 2693 [Subscription] TIU Extractions.
@@ -22,8 +22,6 @@
  ; 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
@@ -37,10 +35,5 @@
  .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
@@ -58,5 +51,5 @@
  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
@@ -99,5 +92,4 @@
  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
  ;
@@ -124,4 +116,5 @@
  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)
@@ -168,5 +161,4 @@
  .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
@@ -178,5 +170,5 @@
  ; 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)
@@ -192,14 +184,11 @@
  ; 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
@@ -209,7 +198,5 @@
  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
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRM7M1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 06/01/2007  15:26
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRM7M1 ;SLC/JVS HL7 PUT MESSAGE IN 772 FILE; 03/21/2002 ;4/11/02  15:26
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;This routine will use the HL7 Package commands to gather the message
  ;into the file 772
@@ -13,5 +13,4 @@
  S HLA("HLS",1)=PXRM77
  D GENERATE^HLMA(HL("EID"),"GM",1,.PXRM7R,.PXRM7ID,)
- D STORE^PXRM7API
  S ID=ZMID
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRM7XT.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 06/01/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRM7XT ;SLC/JVS HL7 EXTRACT FROM FILE; 03/21/2002 ;4/11/02  15:26
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;This is the beginning of the extraction from the extract file
  ;
@@ -7,5 +7,4 @@
  Q
 SPLIT ;SPLIT MESSAGES
- ;
  N ORC2
  I LINE>100 D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMAGE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMAGE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMAGE.m	(revision 636)
@@ -1,4 +1,20 @@
-PXRMAGE ; SLC/PKR - Utilities for age calculations. ;10/07/2005
- ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+PXRMAGE ; SLC/PKR - Utilities for age calculations. ;1/27/07  17:46
+ ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;===========================================
 AGE(DOB,DOD,DATE) ;Given a date of birth, date of death, and a date
@@ -6,24 +22,42 @@
  ;return the age on the date of death. All dates should be in VA
  ;Fileman format.
- N CDATE
+ N CDATE,X,X1,X2,X3
  S CDATE=$S(DOD="":DATE,DOD'="":DOD)
- Q (CDATE-DOB)\10000
+ S X=(CDATE-DOB)\10000 Q:X>1 X ; Begin VOE changes to support pediatrics
+ S X1=CDATE,X2=DOB
+ D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,1:X_"D")
+ Q X ; End VOE changes to support pediatric ages
  ;
  ;===========================================
-AGECHECK(AGE,MINAGE,MAXAGE) ;Given an AGE, MINimumAGE, and MAXimumAGE
+AGECHECK(PXRMAGE,MINAGE,MAXAGE) ;Given an AGE (with "Y", "M" or "D"), MINimumAGE, and MAXimumAGE
  ;return true if age lies within the range.
  ;Special values of NULL or 0 mean there are no limits.
  ;
- S MAXAGE=+MAXAGE
- S MINAGE=+MINAGE
+ ; IHS/CIA/MGH - 5/12/2004 PATCH 1001 Changed to function call to calculate age
+ ; Two lines changed and one added ; for VOE too
+ ;S MAXAGE=+MAXAGE
+ ;S MINAGE=+MINAGE
+ ;
+ S MAXAGE=$$DECODE(MAXAGE) ; DECODE used in VOE Pediatric patients
+ S MINAGE=$$DECODE(MINAGE)
+ S AGEDAYS=$$DECODE(PXRMAGE)
+ ;
  ;See if too old.
- I (AGE>MAXAGE)&(MAXAGE>0) Q 0
+ I (AGEDAYS>MAXAGE)&(MAXAGE>0) Q 0
  ;
  ;See if too young.
  I MINAGE=0 Q 1
- I AGE<MINAGE Q 0
+ I AGEDAYS<MINAGE Q 0
  Q 1
  ;
- ;===========================================
+DECODE(AGEVALUE) ; Put age from VADPT into format for reminders ; for VOE too
+ ; IHS/CIA/MGH - 5/12/2004 PATCH 1001 Added function to change age into days
+ N NUM,CODE,MULT
+ S NUM=+AGEVALUE,CODE=$P(AGEVALUE,NUM,2)
+ S MULT=1.0
+ I CODE="M" S MULT=30.42
+ I CODE=""!(CODE="Y") S MULT=365.25
+ Q +(MULT*NUM)
+ ;======================================================================
 FMTAGE(MINAGE,MAXAGE) ;Format the minimum age and maximum age for display.
  N STR
@@ -79,16 +113,17 @@
 OVERLAP(NAR,MINA,MAXA) ;Check age ranges for overlap.  Return an error message
  ;if an overlap is found.
+ ;IHS/CIA/MGH Changes made to decode the ages into numeric results
  I NAR'>1 Q 0
  N IC,IN,JC,MAXI,MAXJ,MINI,MINJ,OVRLAP,TEXT
  S OVRLAP=0
  F IC=1:1:NAR-1 D
- . S MAXI=MAXA(IC)
+ . S MAXI=$$DECODE(MAXA(IC)) ; DECODE used in VOE Pediatric patients
  . I MAXI="" S MAXI=1000
- . S MINI=MINA(IC)
+ . S MINI=$$DECODE(MINA(IC))
  . I MINI="" S MINI=0
  . F JC=IC+1:1:NAR D
- .. S MAXJ=MAXA(JC)
+ .. S MAXJ=$$DECODE(MAXA(JC))
  .. I MAXJ="" S MAXJ=1000
- .. S MINJ=MINA(JC)
+ .. S MINJ=$$DECODE(MINA(JC))
  .. I MINJ="" S MINJ=0
  .. S IN=0
@@ -122,2 +157,23 @@
  Q OVERLAP
  ;
+ ;======================================================================
+RESTORE(SOURCE,INDEX,FREQ,MINAGE,MAXAGE) ;Restore FREQ, MINAGE, and
+ ;MAXAGE back to the original form.  From IHS for VOE
+ N IND,TEMP
+ I SOURCE="CFIND" D
+ . S IND=$O(^PXD(811.9,PXRMITEM,10,"B",INDEX,""))
+ . S TEMP=^PXD(811.9,PXRMITEM,10,IND,0)
+ ;
+ I SOURCE="HFIND" D
+ . S IND=$O(^PXD(811.9,PXRMITEM,6,"B",INDEX,""))
+ . S TEMP=^PXD(811.9,PXRMITEM,6,IND,0)
+ ;
+ I SOURCE="TFIND" D
+ . S IND=$O(^PXD(811.9,PXRMITEM,4,"B",INDEX,""))
+ . S TEMP=^PXD(811.9,PXRMITEM,4,IND,0)
+ ;
+ S MINAGE=$P(TEMP,U,2)
+ S MAXAGE=$P(TEMP,U,3)
+ S FREQ=$P(TEMP,U,4)
+ Q
+ ; 
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCDUE.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;09/05/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMCDUE ;SLC/PKR - Custom date due calculation routines. ;06/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;========================================================
@@ -38,8 +38,7 @@
  . S FI=$P(TEMP,U,1)
  . S FREQ=$P(TEMP,U,2)
- . S DATE=$S(FIEVAL(FI):+FIEVAL(FI,"DATE"),1:0)
- . I DATE>0 S DATE=$$FULLDATE^PXRMDATE(DATE)
+ . S DATE=+$G(FIEVAL(FI,"DATE"))
  . S DLIST(IND)=$$NEWDATE^PXRMDATE(DATE,FREQ)
- S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST),1:0)
+ S TEMP=$S(FUNCTION="MAX_DATE":$$MAXDATE(NARGS,.DLIST),FUNCTION="MIN_DATE":$$MINDATE(NARGS,.DLIST))
  S DDUE=$P(TEMP,U,1)
  I DDUE=0 Q -1
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCF.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMCF ; SLC/PKR - Handle computed findings. ;07/25/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMCF ; SLC/PKR - Handle computed findings. ;12/15/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=======================================================
@@ -63,9 +63,8 @@
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  S TEST=PFINDPA(15)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
- S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
- ;Make sure NGET has the same sign as NOCC.
- I NGET'=NOCC S NGET=NGET*($$ABS^XLFMTH(NOCC)/NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  S TEMP=^PXRMD(811.4,ITEM,0)
  S TYPE=$P(TEMP,U,5)
@@ -127,5 +126,5 @@
  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)"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCOND.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;06/01/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMCOND ; SLC/PKR - Routines for evaluating conditions. ;11/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;============================================================
@@ -79,6 +79,5 @@
  S CONDS=$G(FINDPA(3))
  S COND=$P(CONDS,U,1)
- ;Even if there is no condition UCIFS could be used for status search.
- S UCIFS=$P(CONDS,U,3)
+ S UCIFS=$S(COND="":0,1:$P(CONDS,U,3))
  I COND="" Q
  S CASESEN=$P(CONDS,U,2)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMCOPY.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;09/13/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMCOPY ; SLC/PKR,PJH - Copy various reminder files. ;05/11/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================
@@ -12,5 +12,5 @@
  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
@@ -64,18 +64,9 @@
  ;
  ;=====================================================
-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
@@ -86,5 +77,5 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATA.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDATA ; SLC/PKR - Routines for getting data. ;04/02/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDATA ; SLC/PKR - Routines for getting data. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;===============================================
@@ -13,5 +13,5 @@
  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
@@ -57,5 +57,5 @@
  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
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;01/24/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;==================================================
@@ -48,8 +48,5 @@
  ;forms as well as T-NY to a FileMan date. Also understands LAD for
  ;Last Admission Date.
- N %DT,ND,X,Y
- ;Already a FileMan date?
- S ND=+DATE
- I (ND'<1000000),(ND'>9991231) Q DATE
+ N %DT,X,Y
  ;Check for a date FileMan understands.
  S X=DATE,%DT="ST"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDBL3.m	(revision 636)
@@ -1,10 +1,9 @@
-PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;11/08/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDBL3 ; SLC/PJH - Reminder Dialog Generation. (overflow) ;04/30/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ; Called from PXRMDBL1
  ;
  ;Set number range for site
-START ;
- D SETSTART^PXRMCOPY("^PXRMD(801.41,")
+START D SETSTART^PXRMCOPY("^PXRMD(801.41,")
  ;Update dialog file for individual dialog items
  D UPDATE(.ARRAY,.WPTXT,"E")
@@ -64,11 +63,13 @@
  N RNAME,TEST,YT S YT=""
  ;Convert ien to name
- ;DBIA #5044
- S YT("CODE")=$P($G(^YTT(601.71,IEN,0)),U)
+ S YT("CODE")=$P($G(^YTT(601,IEN,0)),U)
  ;Quit if no code found
  I YT("CODE")="" Q 0
- I '$$OK^PXRMDLL(IEN) Q 0
+ ;Check if this is an allowable GUI test
+ I (YT("CODE")'="GAF"),($P($G(^YTT(601.6,IEN,0)),U,4)'="Y") Q 0
+ ;Get details of test
+ D SHOWALL^YTAPI3(.TEST,.YT)
  ;Check if valid
- ;I TEST(1)["[ERROR]" Q 0
+ I TEST(1)["[ERROR]" Q 0
  ;
  S DNAME=FTYP_" "_YT("CODE")
@@ -82,9 +83,8 @@
  ;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
@@ -130,5 +130,5 @@
  ..;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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDEDT.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;10/18/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDEDT ; SLC/PJH - Edit PXRM reminder dialog. ;07/28/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Used by protocol PXRM SELECTION ADD/PXRM GENERAL ADD
@@ -63,5 +63,4 @@
  ;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
@@ -276,6 +275,4 @@
  .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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDEV.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;01/24/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDEV ; SLC/PKR - This is a driver for testing Clinical Reminders.;05/04/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;==================================================
@@ -32,4 +32,5 @@
  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
@@ -67,4 +68,5 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLG4.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;06/05/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDLG4 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;10/31/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 WP(SUB,SUB1,WIDTH,SEQ,VALMCNT) ;Format WP text
@@ -22,6 +22,8 @@
  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
@@ -61,4 +63,5 @@
  .;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
@@ -74,5 +77,5 @@
 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=""
@@ -86,4 +89,7 @@
  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
@@ -142,11 +148,4 @@
  ..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)
@@ -166,4 +165,5 @@
 FDESC(FIEN) ;Finding description
  N FGLOB,FITEM,FNUM
+ ;Determine finding type
  S FGLOB=$P(FIEN,";",2) Q:FGLOB=""
  S FITEM=$P(FIEN,";") Q:FITEM=""
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLG5.m	(revision 636)
@@ -1,19 +1,5 @@
-PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;11/08/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDLG5 ; SLC/PJH - Reminder Dialog Edit/Inquiry ;05/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
-ALT(DIEN,LEV,DSEQ,NODE,VIEW,NLINE,CNT,ALTLEN) ;
- ;Display branching logic text in dialog summary view
- N DATA,DNAM,DTYP,IEN,TERM,TNAME,TSTAT,TEMP
- S DATA=$G(^PXRMD(801.41,DIEN,49))
- I '+$P(DATA,U)!($P($G(DATA),U,2)="") Q
- S TNAME=$P($G(^PXRMD(811.5,$P(DATA,U),0)),U)
- S TSTAT=$S($P(DATA,U,2)="1":"TRUE",1:"FALSE")
- I +$P(DATA,U,3)>0 D
- .S IEN=$P(DATA,U,3),DNAM=$P($G(^PXRMD(801.41,IEN,0)),U)
- .S DTYP=$S($P($G(^PXRMD(801.41,IEN,0)),U,4)="E":"Element",$P($G(^PXRMD(801.41,IEN,0)),U,4)="G":"Group")
- I $G(DNAM)="" S TEMP="Suppressed if Reminder Term "_TNAME_" evaluates as "_TSTAT
- I $G(DNAM)'="" S TEMP="Replaced by "_DNAM_" if Reminder Term "_TNAME_" evaluates as "_TSTAT
- D TEXT(.NLINES,CNT,ALTLEN,TEMP,NODE)
- Q
  ;
 ASK(YESNO,PIEN) ;Confirm
@@ -36,4 +22,44 @@
  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) ;
@@ -59,5 +85,5 @@
  I VALUE=4 D
  .;Patient Specific field
- .S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set to true"
+ .S HTEXT(1)="Enter either 1 for true or 0 for false. This value must be set totrue"
  .S HTEXT(2)="if item in this dialog will be using reminder term to either replace an item"
  .S HTEXT(3)="or to suppress an item."
@@ -65,5 +91,14 @@
  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]
@@ -84,139 +119,2 @@
  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
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLGZ.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;01/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDLGZ ; SLC/PJH - Link reminder to dialog. ;05/31/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Called by option PXRM DIALOG/COMPONENT EDIT
@@ -229,6 +229,10 @@
  .W $C(7),!,"A taxonomy cannot be entered as the finding item for a group"
  ;Only applies to MH
- I $P(X,";",2)'="^YTT(601.71," Q 1
- I $$OK^PXRMDLL($P(X,";")) Q 1
+ I $P(X,";",2)'="YTT(601," Q 1
+ ;GAF
+ I $P($G(^YTT(601,$P(X,";"),0)),U)="GAF" Q 1
+ ;Check if a VALID GUI test
+ I $P($G(^YTT(601.6,$P(X,";"),0)),U,4)="Y" Q 1
+ ;else
  W *7,!,"This test is not appropriate for the GUI",!
  Q 0
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLL.m	(revision 636)
@@ -1,8 +1,10 @@
 PXRMDLL ;SLC/PJH - REMINDER DIALOG LOADER ;09/26/2007
- ;;2.0;CLINICAL REMINDERS;**10,6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;**10**;Feb 04, 2005;Build 25
  ;
 OK(DIEN) ;Check if mental health test is for GUI
- I 'DIEN Q 0
- Q $$MH^PXRMDLG5(DIEN)
+ I 'DFIEN Q 0
+ I $P($G(^YTT(601.6,DFIEN,0)),U,4)="Y" Q 1
+ I $P($G(^YTT(601,DFIEN,0)),U)="GAF" Q 1
+ Q 0
  ;
 TXT ;Format text
@@ -100,7 +102,5 @@
  .I $P($G(^PXRMD(801.41,DGIEN,2)),U,3) S DEXC=1
  .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11) Q:"EG"'[DTYP
- .S DMHEX=$P(DATA,U,14)
- .S DRESL=$$RESGROUP^PXRMDLLB(DGIEN)
- .;S DRESL=$P(DATA,U,15)
+ .S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
  .S DRES=$P($G(^PXRMD(801.41,DGIEN,1)),U,3)
  .;Done Elsewhere (historical)
@@ -146,5 +146,5 @@
  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"
@@ -168,7 +168,5 @@
  ..D REPLACE^PXRMDLLB(DFN,TERMNODE,.DITEM,.DATA,.TERMSTAT)
  .S DTYP=$P(DATA,U,4),DSUPP=$P(DATA,U,11)
- .S DMHEX=$P(DATA,U,14)
- .S DRESL=$$RESGROUP^PXRMDLLB(DITEM)
- .;S DRESL=$P(DATA,U,15)
+ .S DMHEX=$P(DATA,U,14),DRESL=$P(DATA,U,15)
  .K DTXT S SUB=0
  .F  S SUB=$O(^PXRMD(801.41,DITEM,25,SUB)) Q:'SUB  D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLA.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;11/08/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLLA ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
 FREC(DFIEN,DFTYP) ;Build type 3 record
@@ -25,9 +25,7 @@
  .;If mental health check if a GAF score and if MH test is required
  .I DPCE="MH",DFIEN D
- ..;DBIA #5044
- ..I $P($G(^YTT(601.71,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
+ ..I $P($G(^YTT(601,DFIEN,0)),U)="GAF" S $P(ORY(OCNT),U,12)=1
  ..;Check to see if the MH test is required
- ..S $P(ORY(OCNT),U,13)=+$P($G(^PXRMD(801.41,DITEM,0)),U,18)
- ..I $P(ORY(OCNT),U,13)=2,$$PATCH^XPDUTL("OR*3.0*243")=0 S $P(ORY(OCNT),U,13)=1
+ ..S $P(ORY(OCNT),U,13)=$S($P($G(^PXRMD(801.41,DITEM,0)),U,18)=1:1,1:0)
  Q
  ;
@@ -52,5 +50,5 @@
  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"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLLB.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;05/01/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLLB ;SLC/PJH - REMINDER DIALOG LOADER ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
 CODE(DFIEN,DFTYP,ARRAY) ;
@@ -108,16 +108,4 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLR.m	(revision 636)
@@ -1,31 +1,23 @@
-PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;05/15/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLR ;SLC/PJH - DIALOG RESULTS LOADER ;06/09/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;Build score related P/N text from score and result group
  ; 
  ;If not found
-START(ORY,RESULT,ORES) ;
  I '$G(RESULT) S ORY(1)="-1^no results for this test" Q
  ;
- N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT,X
+ N ARRAY,ERROR,INSERT,OK,SCORE,SUB,YT
  ;
- I RESULT["~" S RESULT=$P(RESULT,"~")
  S ERROR=0
  ;
  ;Get score using API
- K ^TMP($J,"YSCOR")
+ S DFN=$G(ORES("DFN"))
  I ORES("CODE")'="DOM80" D  Q:ERROR
  .M YT=ORES
- .F X=1:1:$L(YT("R1")) I $E(YT("R1"),X)'="X" S YT(X)=X_U_$E(YT("R1"),X)
- .K YT("R1")
- .D CHECKCR^YTQPXRM4(.ARRAY,.YT)
- .S OK=0
- .;D PREVIEW^YTAPI4(.ARRAY,.YT)
- .I ^TMP($J,"YSCOR",1)'="[DATA]" S ORY(1)="-1^"_^TMP($J,"YSCOR",1)_^TMP($J,"YSCOD",2),ERROR=1 Q 
- .;I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
- .I $P($G(^TMP($J,"YSCOR",2)),"=",2)'="" S SCORE=$P($G(^TMP($J,"YSCOR",2)),"=",2),OK=1
- .;S SUB=0,OK=0
- .;F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
- .;.I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
+ .D PREVIEW^YTAPI4(.ARRAY,.YT)
+ .I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2),ERROR=1 Q
+ .S SUB=0,OK=0
+ .F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  Q:OK
+ ..I $P(ARRAY(SUB),U)="S1" S SCORE=$P(ARRAY(SUB),U,3),OK=1
  .I 'OK S ORY(1)="-1^[ERROR] no score returned",ERROR=1 Q
  ;
@@ -36,5 +28,4 @@
  .S SCORE=0
  ;
- S DFN=$G(ORES("DFN"))
  S INSERT("SCORE")=SCORE
  ;
@@ -49,6 +40,4 @@
  .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
@@ -83,8 +72,4 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDLR1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 11/16/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMDLR1 ; SLC/AGP - DIALOG ORPHAN REPORT. ; 02/04/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=======================================================================
@@ -42,5 +42,5 @@
  . 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
@@ -66,5 +66,5 @@
  . .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
@@ -79,5 +79,5 @@
 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 !
@@ -86,4 +86,4 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDNVA.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;03/14/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDNVA ; SLC/PKR - Handle non-VA med findings. ;05/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;===============================================
@@ -18,9 +18,8 @@
  ;====================================================
 MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
- N DATE,JND,NOUT,TEMP,TEXTOUT
+ N JND,NOUT,TEMP,TEXTOUT
  S TEMP="Non-VA med: "_IFIEVAL("ORDERABLE ITEM")_" = "
  S TEMP=TEMP_"("_$$EDATE^PXRMDATE(IFIEVAL("START DATE"))
- S DATE=IFIEVAL("DISCONTINUED DATE")
- S DATE=$S(DATE="":"NONE",1:$$EDATE^PXRMDATE(DATE))
+ S TEMP=TEMP_" - "_$$EDATE^PXRMDATE(IFIEVAL("STOP DATE"))_")"
  D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDRGR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/20/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDRGR ; SLC/PKR - Handle groups of drug findings. ;06/12/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;Groups are drug classes or VA Generic.
  ;==================================================
@@ -100,6 +100,4 @@
  .. 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)
@@ -185,13 +183,2 @@
  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
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDRUG.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMDRUG ; SLC/PKR - Handle drug findings. ;04/23/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMDRUG ; SLC/PKR - Handle drug findings. ;06/08/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;===============================================
@@ -114,5 +114,5 @@
  ;===============================================
 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
@@ -159,7 +159,5 @@
  .. D DORDER^PXRMTERM(.DTFIEVAL,.DATEORDR)
  .. D COPY^PXRMTERM(NOCC,SDIR,.DTFIEVAL,.DATEORDR,TFINDING,.TFIEVAL)
- ..;Save the dispense drug
- .. S JND=0
- .. F  S JND=+$O(TFIEVAL(TFINDING,JND)) Q:JND=0  S TFIEVAL(TFINDING,JND,"DISPENSE DRUG")=DRUGIEN
+ .. I TFIEVAL(TFINDING) S TFIEVAL(TFINDING,"DISPENSE DRUG")=DRUGIEN
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEDIT.m	(revision 636)
@@ -1,9 +1,6 @@
-PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;06/04/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEDIT ; SLC/PKR - Clinical Reminder edit driver. ;05/18/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
 EDIT(ROOT,IENN) ;Call the appropriate edit routine.
- ;Reminder location list
- I ROOT="^PXRMD(810.9," D EDIT^PXRMLLED(ROOT,IENN) Q
- ;
  ;Taxonomy
  I ROOT="^PXD(811.2," D EDIT^PXRMTEDT(ROOT,IENN) Q
@@ -12,5 +9,5 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMENOD.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;12/13/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMENOD ; SLC/PKR - Clinical Reminders "E" node routines. ;04/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;========================================================
@@ -30,5 +30,5 @@
  ;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)
@@ -44,7 +44,6 @@
  S DAS=IEN
  I DAS="" Q
- S NAME=""
- I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
- I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=NAME
+ I FILENUM=811.5 S ^PXRMD(811.5,DA(1),20,"E",GLOBAL,DAS,DA)=""
+ I FILENUM=811.9 S ^PXD(811.9,DA(1),20,"E",GLOBAL,DAS,DA)=""
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEPM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;07/17/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEPM ; SLC/PKR/PJH - Extract Definition Management ;06/21/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM EXTRACT DEFINITIONS
@@ -13,5 +13,9 @@
  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
  ;
@@ -61,10 +65,10 @@
  .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)
@@ -82,4 +86,5 @@
  ;
 EPADD ;Add Rule Option
+ ;
  ;Reset Screen Mode
  W IORESET
@@ -90,4 +95,5 @@
  ;Rebuild Workfile
  D BLDLIST
+ ;
  S VALMBCK="R"
  Q
@@ -103,5 +109,5 @@
  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
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETCO.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;03/27/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETCO ; SLC/PJH - QUERI Extract Compliance Report ;01/19/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;
@@ -33,5 +33,5 @@
  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
@@ -41,9 +41,7 @@
  .S SUFFIX=$P(DATA,U,3)
  .I SUFFIX="" S SUFFIX="DENOMINATOR "_SEQ
- .S INDP=+$P(DATA,U,4)
- .S INTP=+$P(DATA,U,5)
  .;Create new patient list
- .S PXRMLIST=$$CRLST^PXRMRUL1(LIST_" "_SUFFIX) Q:'PXRMLIST
- .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,INDP,INTP)
+ .S PXRMLIST=$$CRLST^PXRMRULE(LIST_" "_SUFFIX) Q:'PXRMLIST
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,"","")
  .;Clear ^TMP lists created for rule
  .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
@@ -120,6 +118,5 @@
  W !,"Queue the Clinical Reminders MST synchronization."
  S DIR("A",1)="Enter the date and time you want the job to start."
- S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
- S DIR("A")="Start the task at: "
+ S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
  S DIR(0)="DAU"_U_MINDT_"::RSX"
  D ^DIR
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETH.m	(revision 636)
@@ -1,12 +1,11 @@
-PXRMETH ; SLC/PJH - Reminder Extract History ;10/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETH ; SLC/PJH - Reminder Extract History ;08/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM EXTRACT HISTORY
-START(EDIEN) ;
- ;EDIEN is the extract definition IEN.
+START(IEN) ;
  N VALMBCK,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
  ;Details of last run
  N DATA,NPERIOD,NSDATE,NTAS,PXRMVIEW
- S DATA=$G(^PXRM(810.2,EDIEN,0))
+ S DATA=$G(^PXRM(810.2,IEN,0))
  S NPERIOD=$P(DATA,U,6),NSDATE=$P(DATA,U,7)
  ;Default view is in date created order
@@ -18,18 +17,6 @@
  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
  ;
@@ -42,5 +29,88 @@
  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
@@ -51,6 +121,6 @@
  N ANS,DATA,DUOUT,DTOUT,EDATE,EXSUMPUG,FREQ,MODE
  N NAME,NAT,NEXT,PLISTPUG,RTN,REPL,STATUS,SNEXT,TEXT,XMIT
- S DATA=$G(^PXRM(810.2,EDIEN,0))
- S NAT=$P($G(^PXRM(810.2,EDIEN,100)),U)
+ S DATA=$G(^PXRM(810.2,IEN,0))
+ S NAT=$P($G(^PXRM(810.2,IEN,100)),U)
  ;Determine Extract Name and Frequency
  S NAME=$P(DATA,U),FREQ=$P(DATA,U,3),NEXT=$P(DATA,U,6),RTN="PXRMETX"
@@ -93,6 +163,6 @@
  N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
  S ZTDESC="Reminder Extract "_NAME
- S ZTRTN="RUN^PXRMETX(EDIEN,NEXT,MODE,EXSUMPUG)"
- S ZTSAVE("EDIEN")=""
+ S ZTRTN="RUN^PXRMETX(IEN,NEXT,MODE,EXSUMPUG)"
+ S ZTSAVE("IEN")=""
  S ZTSAVE("MODE")=""
  S ZTSAVE("NEXT")=""
@@ -117,46 +187,10 @@
  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.
@@ -184,29 +218,40 @@
  Q
  ;
-TLIST ;Extract summary display
- N IEN,IENLIST,IND
- S IENLIST=$$LMSEL
- F IND=1:1:$L(IENLIST,U) D
- .S IEN=$P(IENLIST,U,IND)
- .D START^PXRMETT(IEN)
- .S VALMBCK="R"
+TLIST ;Extract Totals
+ N IND,PXRMSIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .D START^PXRMETT(PXRMSIEN)
+ ;
  S VALMBCK="R"
  Q
  ;
 TRANS ;Run Transmission
- N IEN,IENLIST,IND
- S IENLIST=$$LMSEL
- F IND=1:1:$L(IENLIST,U) D
- .S IEN=$P(IENLIST,U,IND)
- .I $P($G(^PXRMXT(810.3,IEN,100)),U)'="N" D  Q
- ..W !,"Local extracts cannot be transmitted to AAC." H 2
+ N IND,PXRMXIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMXIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .I $P($G(^PXRMXT(810.3,PXRMXIEN,100)),U)'="N" D  Q
+ ..W !,"Local extracts cannot be transmitted to AAC." H 1
  .;Transmit extract summary
  .N ANS,DUOUT,DTOUT,RTN,TEXT
  .S TEXT="Transmit this extract to AAC",ANS="",RTN="PXRMETH"
  .S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,3) Q:$D(DUOUT)!$D(DTOUT)
- .I ANS D TRANS^PXRMETX(IEN)
+ .I ANS D TRANS^PXRMETX(PXRMXIEN)
  ;
  ;Rebuild workfile
- D BLDLIST^PXRMETH1(EDIEN)
+ D BLDLIST^PXRMETH1(IEN)
  ;Refresh
  S VALMBCK="R"
@@ -214,9 +259,16 @@
  ;
 TRHIST ;Transmission History
- N IEN,IENLIST,IND
- S IENLIST=$$LMSEL
- F IND=1:1:$L(IENLIST,U) D
- .S IEN=$P(IENLIST,U,IND)
- .D START^PXRMETHL(IEN)
+ N IND,PXRMSIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;PXRMDONE is newed in PXRMLPM
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S PXRMSIEN=^TMP("PXRMETH",$J,"IDX",IND,IND)
+ .D START^PXRMETHL(PXRMSIEN)
+ ;
  S VALMBCK="R"
  Q
@@ -241,6 +293,9 @@
  ;
 VIEW ;Select view
+ ;
  W IORESET
- S VALMBCK="R"
+ ;
+ S VALMBCK="R"
+ ;
  N X,Y,CODE,DIR
  K DIROUT,DIRUT,DTOUT,DUOUT
@@ -259,5 +314,5 @@
  ;
  ;Rebuild Workfile
- D BLDLIST^PXRMETH1(EDIEN),HDR
+ D BLDLIST^PXRMETH1(IEN),HDR
  Q
  ;
@@ -273,67 +328,2 @@
  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
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETH1.m	(revision 636)
@@ -1,26 +1,18 @@
-PXRMETH1 ; SLC/PJH - Reminder Extract History ;09/07/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETH1 ; SLC/PJH - Reminder Extract History ;07/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
-BLDLIST(EDIEN) ;Build workfile
- ;EDIEN is the extract definition IEN.
- N IND,FMTSTR,PLIST
+BLDLIST(IEN) ;Build workfile
+ N IND,PLIST
  K ^TMP("PXRMETH",$J)
- S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLL")
  ;Build list of extract summaries in period order
- I PXRMVIEW="P" D LIST1(EDIEN,"PXRMETH",FMTSTR)
+ I PXRMVIEW="P" D LIST1(.PLIST,.IEN)
  ;Build list of extract summaries in date order
- I PXRMVIEW="D" D LIST2(EDIEN,"PXRMETH",FMTSTR)
- Q
- ;
-FMT(NUMBER,NAME,EDATE,XDATE,AUTO,FMTSTR,NL,OUTPUT) ;Format
- N TAUTO,TDATE,TEMP,TNAME,TSOURCE
- S TEMP=NUMBER_U_NAME_U
- S TDATE=$$FMTE^XLFDT(EDATE,"5Z")
- S TEMP=TEMP_$$LJ^XLFSTR(TDATE,20," ")
- S TDATE=XDATE I TDATE S TDATE=$$FMTE^XLFDT(TDATE,"5Z")
- S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,22," ")
- S TAUTO=AUTO
- S TEMP=TEMP_TAUTO
- D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT)
+ I PXRMVIEW="D" D LIST2(.PLIST,.IEN)
+ ;Move into list array
+ M ^TMP("PXRMETH",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ ;Allow selection by item
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMETH",$J,"IDX",IND,IND)=IEN(IND)
  Q
  ;
@@ -28,8 +20,7 @@
  N HTEXT
  I CALL=1 D
- .S HTEXT(1)="Select DE to delete an extract.\\"
- .S HTEXT(2)="Select ES to view the details of an extract or run a compliance"
- .S HTEXT(3)="report for the extract.\\Select MT to transmit extract details to the AAC.\\"
- .S HTEXT(4)="Select TH to view the transmission history for an extract."
+ .S HTEXT(1)="Select ES to view the details of an extract or run a compliance"
+ .S HTEXT(2)="report for the extract. Select MT to transmit extract details to the AAC."
+ .S HTEXT(3)="Select TH to view the transmission history for an extract."
  ;
  I CALL=3 D
@@ -41,14 +32,13 @@
  Q
  ;
-LIST1(EDIEN,NODE,FMTSTR) ;Build a list of extract summaries for a parameter.
- N AUTO,EDATE,HL7ID,HL7SUB,IND,JND,NAME,NL,NUM,OUTPUT
- N PERIOD,STR,XDATE,YEAR
+LIST1(LIST,IEN) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,NAME,PERIOD,XDATE,YEAR
  ;Build list of extract summaries in reverse date order.
- S YEAR="9999",(NUM,VALMCNT)=0
- F  S YEAR=$O(^PXRMXT(810.3,"D",EDIEN,YEAR),-1) Q:YEAR=""  D
+ S YEAR="9999",VALMCNT=0
+ F  S YEAR=$O(^PXRMXT(810.3,"D",IEN,YEAR),-1) Q:YEAR=""  D
  .S PERIOD="99"
- .F  S PERIOD=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD),-1) Q:PERIOD=""  D
+ .F  S PERIOD=$O(^PXRMXT(810.3,"D",IEN,YEAR,PERIOD),-1) Q:PERIOD=""  D
  ..S IND=""
- ..F  S IND=$O(^PXRMXT(810.3,"D",EDIEN,YEAR,PERIOD,IND),-1) Q:IND=""  D
+ ..F  S IND=$O(^PXRMXT(810.3,"D",IEN,YEAR,PERIOD,IND),-1) Q:IND=""  D
  ...S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
  ...S EDATE=$P($G(^PXRMXT(810.3,IND,0)),U,6)
@@ -59,21 +49,18 @@
  ...I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
  ...I 'XDATE S XDATE="Not Transmitted"
- ...S NUM=NUM+1
- ...D FMT(NUM,NAME,EDATE,XDATE,AUTO,FMTSTR,.NL,.OUTPUT)
- ...F JND=1:1:NL D
- ....S VALMCNT=VALMCNT+1,^TMP(NODE,$J,VALMCNT,0)=OUTPUT(JND)
- ....S ^TMP(NODE,$J,"IDX",VALMCNT,NUM)=""
- ....S ^TMP(NODE,$J,"SEL",NUM)=IND
+ ...S VALMCNT=VALMCNT+1
+ ...S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO)
+ ...S IEN(VALMCNT)=IND
+ S LIST("VALMCNT")=VALMCNT
  Q
  ;
-LIST2(EDIEN,NODE,FMTSTR) ;Build a list of extract summaries for a parameter.
- N AUTO,EDATE,HL7ID,HL7SUB,IND,JND,NAME,NL,NUM,OUTPUT
- N PERIOD,STR,XDATE,YEAR
+LIST2(LIST,IEN) ;Build a list of extract summaries for a parameter.
+ N AUTO,EDATE,HL7ID,HL7SUB,IND,NAME,PERIOD,XDATE,YEAR
  ;Build list of extract summaries in reverse date order.
- S EDATE="",(NUM,VALMCNT)=0
- F  S EDATE=$O(^PXRMXT(810.3,"C",EDIEN,EDATE),-1) Q:'EDATE  D
+ S EDATE="",VALMCNT=0
+ F  S EDATE=$O(^PXRMXT(810.3,"C",IEN,EDATE),-1) Q:'EDATE  D
  .S IND=""
- .F  S IND=$O(^PXRMXT(810.3,"C",EDIEN,EDATE,IND)) Q:'IND  D
- ..S NAME=$P($G(^PXRMXT(810.3,IND,0)),U,1)
+ .F  S IND=$O(^PXRMXT(810.3,"C",IEN,EDATE,IND)) Q:'IND  D
+ ..S NAME=$P($G(^PXRMXT(810.3,IND,0)),U)
  ..S AUTO=$P($G(^PXRMXT(810.3,IND,4)),U,5)
  ..S AUTO=$S(AUTO="A":"Y",1:"N")
@@ -82,10 +69,20 @@
  ..I HL7SUB S XDATE=$P($G(^PXRMXT(810.3,IND,5,HL7SUB,0)),U,2)
  ..I 'XDATE S XDATE="Not Transmitted"
- ..S NUM=NUM+1
- ..D FMT(NUM,NAME,EDATE,XDATE,AUTO,FMTSTR,.NL,.OUTPUT)
- ..F JND=1:1:NL D
- ...S VALMCNT=VALMCNT+1,^TMP(NODE,$J,VALMCNT,0)=OUTPUT(JND)
- ...S ^TMP(NODE,$J,"IDX",VALMCNT,NUM)=""
- ...S ^TMP(NODE,$J,"SEL",NUM)=IND
+ ..S VALMCNT=VALMCNT+1
+ ..S LIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,EDATE,XDATE,AUTO)
+ ..S IEN(VALMCNT)=IND
+ S LIST("VALMCNT")=VALMCNT
  Q
  ;
+FRE(NUMBER,NAME,EDATE,XDATE,AUTO) ;Format
+ N TAUTO,TDATE,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,27)
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TNAME,27," ")
+ S TDATE=$$FMTE^XLFDT(EDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,20," ")
+ S TDATE=XDATE I TDATE S TDATE=$$FMTE^XLFDT(TDATE,"5Z")
+ S TEMP=TEMP_" "_$$LJ^XLFSTR(TDATE,22," ")
+ S TAUTO=AUTO
+ S TEMP=TEMP_TAUTO
+ Q TEMP
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;09/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETM ; SLC/PKR/PJH - Extract/Transmission Management ;05/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM EXTRACT MANAGEMENT
@@ -15,6 +15,35 @@
  K ^TMP("PXRMETM",$J)
  N IEN,IND,PLIST
- D LIST("PXRMETM",.VALMCNT)
+ D LIST(.PLIST,.IEN)
+ M ^TMP("PXRMETM",$J)=PLIST
+ S VALMCNT=PLIST("VALMCNT")
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMETM",$J,"IDX",IND,IND)=IEN(IND)
  Q
+ ;
+LIST(RLIST,IEN) ;Build a list of extract definition entries.
+ N EPCLASS,IND,FNAME,NAME
+ ;Build the list in alphabetical order.
+ S VALMCNT=0
+ S NAME=""
+ F  S NAME=$O(^PXRM(810.2,"B",NAME)) Q:NAME=""  D
+ .S IND=$O(^PXRM(810.2,"B",NAME,"")) Q:'IND
+ .S FNAME=$P($G(^PXRM(810.2,IND,0)),U)
+ .S EPCLASS=$P($G(^PXRM(810.2,IND,100)),U)
+ .S VALMCNT=VALMCNT+1
+ .S RLIST(VALMCNT,0)=$$FRE(VALMCNT,FNAME,EPCLASS)
+ .S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
+ Q
+ ;
+FRE(NUMBER,NAME,CLASS) ;Format  entry number, name
+ ;and date packed.
+ N TCLASS,TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,46)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
+ S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
+ S TEMP=TEMP_"  "_TCLASS
+ Q TEMP
  ;
 ENTRY ;Entry code
@@ -30,68 +59,7 @@
  Q
  ;
-FMT(NUMBER,NAME,CLASS) ;Format  entry number, name
- ;and date packed.
- N TCLASS,TEMP,TNAME,TSOURCE
- S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
- S TNAME=$E(NAME,1,46)
- S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,60," ")
- S TCLASS=$S(CLASS="N":"NATIONAL",CLASS="V":"VISN",1:"LOCAL")
- S TEMP=TEMP_"  "_TCLASS
- Q TEMP
- ;
-GEN ;Ad hoc report option
- ;Reset Screen Mode
- W IORESET
- ;
- N IND,LISTIEN,VALMY
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q
- S PXRMDONE=0
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S LISTIEN=^TMP("PXRMETM",$J,"SEL",IND)
- .D GENSEL(LISTIEN)
- ;
- S VALMBCK="R"
- Q
- ;
-GENSEL(IEN) ;Report for selected extract definition
- N ANS,BEGIN,END,RTN,TEXT
- D DATES^PXRMEUT(.BEGIN,.END,"Report")
- ;Options
- S RTN="PXRMETM",TEXT="Run compliance report for this period"
- S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:'ANS  Q:$D(DUOUT)!$D(DTOUT)
- ;Print Report
- D ADHOC^PXRMETCO(IEN,BEGIN,END)
- Q
- ;
 HDR ; Header code
  S VALMHDR(1)="Available Extract Definitions:"
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- Q
- ;
-HELP(CALL) ;General help text routine
- N HTEXT
- I CALL=1 D
- .S HTEXT(1)="Select EDM to edit/display extract definitions.\\"
- .S HTEXT(2)="Select VSE to view previous extracts or"
- .S HTEXT(3)="initiate a manual extract or transmission."
- D HELP^PXRMEUT(.HTEXT)
- Q
- ;
-HLIST ;Extract History
- N IND,LISTIEN,VALMY
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q
- S PXRMDONE=0
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S LISTIEN=^TMP("PXRMETM",$J,"SEL",IND)
- .D START^PXRMETH(LISTIEN)
- S VALMBCK="R"
  Q
  ;
@@ -106,37 +74,8 @@
  Q
  ;
-LIST(NODE,VALMCNT) ;Build a list of extract definition entries.
- N EPCLASS,IND,FNAME,NAME
- ;Build the list in alphabetical order.
- S VALMCNT=0
- S NAME=""
- F  S NAME=$O(^PXRM(810.2,"B",NAME)) Q:NAME=""  D
- .S IND=$O(^PXRM(810.2,"B",NAME,"")) Q:'IND
- .S FNAME=$P($G(^PXRM(810.2,IND,0)),U)
- .S EPCLASS=$P($G(^PXRM(810.2,IND,100)),U)
- .S VALMCNT=VALMCNT+1
- .S ^TMP(NODE,$J,VALMCNT,0)=$$FMT(VALMCNT,FNAME,EPCLASS)
- .S ^TMP(NODE,$J,"IDX",VALMCNT,VALMCNT)=""
- .S ^TMP(NODE,$J,"SEL",VALMCNT)=IND
- Q
- ;
 PEXIT ;Protocol exit code
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
  ;Reset after page up/down etc
  D XQORM
- Q
- ;
-PLIST ;Extract Definition Inquiry
- N IND,EPIEN,VALMY
- D EN^VALM2(XQORNOD(0))
- ;If there is no list quit.
- I '$D(VALMY) Q
- S PXRMDONE=0
- S IND=""
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .;Get the ien.
- .S EPIEN=^TMP("PXRMETM",$J,"SEL",IND)
- .D START^PXRMEPED(EPIEN)
- S VALMBCK="R"
  Q
  ;
@@ -146,5 +85,5 @@
  ;
 XSEL ;PXRM EXTRACT MANAGEMENT SELECT ENTRY validation
- N EDIEN,SEL
+ N SEL,IEN
  S SEL=$P(XQORNOD(0),"=",2)
  ;Remove trailing ,
@@ -154,10 +93,10 @@
  .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 EDIEN=^TMP("PXRMETM",$J,"SEL",SEL)
+ S IEN=^TMP("PXRMETM",$J,"IDX",SEL,SEL)
  ;
  ;Full screen mode
@@ -178,13 +117,83 @@
  ;
  ;Display Extract Definitions
- I OPTION="EDM" D START^PXRMEPED(EDIEN)
+ I OPTION="EDM" D
+ .D START^PXRMEPED(IEN)
  ;
  ;Examine/Run Extract
- I OPTION="VSE" D START^PXRMETH(EDIEN)
+ I OPTION="VSE" D
+ .D START^PXRMETH(IEN)
  ;
  ;Examine/Run Extract
- I OPTION="ERE" D GENSEL(EDIEN)
+ I OPTION="ERE" D
+ .D GENSEL(IEN)
  ;
  S VALMBCK="R"
  Q
  ;
+HELP(CALL) ;General help text routine
+ N HTEXT
+ I CALL=1 D
+ .S HTEXT(1)="Select EDM to edit/display extract definitions."
+ .S HTEXT(2)="extract. Select VSE to view previous extracts or "
+ .S HTEXT(3)="initiate a manual extract or transmission."
+ ;
+ D HELP^PXRMEUT(.HTEXT)
+ Q
+ ;
+GEN ;Ad hoc report option
+ ;
+ ;Reset Screen Mode
+ W IORESET
+ ;
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LISTIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D GENSEL(LISTIEN)
+ ;
+ S VALMBCK="R"
+ Q
+ ;
+GENSEL(IEN) ;Report for selected extract definition
+ N ANS,BEGIN,END,RTN,TEXT
+ D DATES^PXRMEUT(.BEGIN,.END,"Report")
+ ;Options
+ S RTN="PXRMETM",TEXT="Run compliance report for this period"
+ S ANS=$$ASKYN^PXRMEUT("N",TEXT,RTN,1) Q:'ANS  Q:$D(DUOUT)!$D(DTOUT)
+ ;Print Report
+ D ADHOC^PXRMETCO(IEN,BEGIN,END)
+ Q
+ ;
+HLIST ;Extract History
+ N IND,LISTIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S LISTIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D START^PXRMETH(LISTIEN)
+ S VALMBCK="R"
+ Q
+ ;
+PLIST ;Extract Definition Inquiry
+ N IND,EPIEN,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S PXRMDONE=0
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .;Get the ien.
+ .S EPIEN=^TMP("PXRMETM",$J,"IDX",IND,IND)
+ .D START^PXRMEPED(EPIEN)
+ ;
+ S VALMBCK="R"
+ Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETT.m	(revision 636)
@@ -1,6 +1,6 @@
-PXRMETT ; SLC/PJH - Extract Summary Display ;04/09/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
- ;
- ;Main entry point for PXRM EXTRACT SUMMARY
+PXRMETT ; SLC/PKR/PJH - Reminder Patient List Patients ;08/08/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;Main entry point for PXRM PATIENT LIST
 START(IEN) N TOGGLE,TOGGLE1,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
  S X="IORESET"
@@ -11,16 +11,14 @@
  ;
 BLDLIST(IEN,FINDINGS,PATIENT) ;Build workfile.
- ;FINDINGS=1 means display finding totals
  K ^TMP("PXRMETT",$J)
  ;Build a list of extract summary totals.
  N APPL,DATA,DUE,IND,LIST,NDUE,NAPPL,OLIST
- N PLCNT,PLIST,RIEN,RNAME,SARRAY,SEQ,SNAME,STATION,TOT
+ N PLCNT,PLIST,RIEN,RNAME,SARRAY,SNAME,STATION,TOT
  ;Build the list in alphabetical order.
- S VALMCNT=0,OLIST="",PLCNT=0
- S IND=0 F  S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:IND'>0  D
+ S IND=0,VALMCNT=0,OLIST="",PLCNT=0
+ F  S IND=$O(^PXRMXT(810.3,IEN,3,IND)) Q:'IND  D
  .S DATA=$G(^PXRMXT(810.3,IEN,3,IND,0)) Q:DATA=""
  .S RIEN=$P(DATA,U,2) Q:'RIEN
- .S RNAME=$P(^PXD(811.9,RIEN,0),U,3)
- .I RNAME="" S RNAME=$P(^PXD(811.9,RIEN,0),U,1)
+ .S RNAME=$P($G(^PXD(811.9,RIEN,0)),U)
  .S STATION=$P(DATA,U,3),SARRAY=""
  .D GETS^DIQ(4,STATION,99,"E","SARRAY")
@@ -31,8 +29,4 @@
  .S PLIST=$P(DATA,U,4)
  .I PLIST,PLIST'=OLIST D
- ..I PLCNT>0 D
- ...S VALMCNT=VALMCNT+1
- ...S ^TMP("PXRMETT",$J,VALMCNT,0)=""
- ...S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
  ..S PLNAME=$P($G(^PXRMXP(810.5,PLIST,0)),U),OLIST=PLIST Q:PLNAME=""
  ..S VALMCNT=VALMCNT+1,PLCNT=PLCNT+1
@@ -40,6 +34,12 @@
  ..S ^TMP("PXRMETT",$J,"SEL",PLCNT)=PLIST
  ..S ^TMP("PXRMETT",$J,VALMCNT,0)=$$RJ^XLFSTR(PLCNT,4," ")_" "_PLNAME
+ ..S VALMCNT=VALMCNT+1
+ ..S ^TMP("PXRMETT",$J,VALMCNT,0)=""
+ ..S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
  .S VALMCNT=VALMCNT+1
  .S ^TMP("PXRMETT",$J,VALMCNT,0)=$$FRE(VALMCNT,RNAME,SNAME,TOT,APPL,NAPPL,DUE,NDUE)
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=""
  .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
  .;Finding totals
@@ -47,16 +47,5 @@
  ;
  S ^TMP("PXRMETT",$J,"VALMCNT")=VALMCNT
- Q
- ;
-ENTRY ;Entry code
- D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
- Q
- ;
-EXIT ;Exit code
- K ^TMP("PXRMETT",$J)
- K ^TMP("PXRMETTH",$J)
- D CLEAN^VALM10
- D FULL^VALM1
- S VALMBCK="Q"
+ ;M ^TMP("PXRMETT",$J)=LIST
  Q
  ;
@@ -91,7 +80,34 @@
  Q
  ;
+PBLD(IEN,IND,SUB) ;
+ N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
+ S VALMCNT=VALMCNT+1,CNT=0
+ S PCNT=0 F  S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0  D
+ .S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
+ .S NAME=$P($G(^DPT(DFN,0)),U)
+ .S CNT=CNT+1,ARRAY(NAME)=""
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="     "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
+ S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
+ .S VALMCNT=VALMCNT+1
+ .S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
+ .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ S VALMCNT=VALMCNT+1
+ S ^TMP("PXRMETT",$J,VALMCNT,0)="  "
+ S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+ Q
+ ;
 FLIST ;Toggle list with/without finding totals
  S TOGGLE=(TOGGLE+1)#2
  I TOGGLE=0 S TOGGLE1=0
+ ;Rebuild Workfile
+ D BLDLIST(IEN,TOGGLE,TOGGLE1)
+ ;Refresh
+ S VALMBCK="R",VALMBG=1
+ Q
+ ;
+PLIST1 ;Toggle list with/without finding totals
+ S TOGGLE1=(TOGGLE1+1)#2
  ;Rebuild Workfile
  D BLDLIST(IEN,TOGGLE,TOGGLE1)
@@ -125,8 +141,21 @@
  Q TEMP
  ;
+ENTRY ;Entry code
+ D BLDLIST(IEN,TOGGLE,TOGGLE1),XQORM
+ Q
+ ;
+EXIT ;Exit code
+ K ^TMP("PXRMETT",$J)
+ K ^TMP("PXRMETTH",$J)
+ D CLEAN^VALM10
+ D FULL^VALM1
+ S VALMBCK="Q"
+ Q
+ ;
 HDR ; Header code
  S VALMHDR(1)="Extract Summary Name: "_$P($G(^PXRMXT(810.3,IEN,0)),U)
  S VALMHDR(2)="      Extract Period: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,2),"5Z")_" - "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,3),"5Z")
  S VALMHDR(2)=VALMHDR(2)_"   Created: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,6),"5Z")
+ ;S VALMHDR(3)=VALMHDR(3)_"        Transmitted: "_$$FMTE^XLFDT($P($G(^PXRMXT(810.3,IEN,0)),U,4),"5Z")
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
  Q
@@ -142,21 +171,27 @@
  Q
  ;
-PBLD(IEN,IND,SUB) ;
- N ARRAY,NAME,LEN,PCNT,DFN,CNT,USTR
- S VALMCNT=VALMCNT+1,CNT=0
- S PCNT=0 F  S PCNT=$O(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT)) Q:PCNT'>0  D
- .S DFN=$P($G(^PXRMXT(810.3,IEN,3,IND,1,SUB,1,PCNT,0)),U) Q:DFN'>0
- .S NAME=$P($G(^DPT(DFN,0)),U)
- .S CNT=CNT+1,ARRAY(NAME)=""
- S ^TMP("PXRMETT",$J,VALMCNT,0)="     "_$$RJ^XLFSTR("Unique Applicable Patients ("_CNT_")",36," ")
- S USTR=$P($G(^TMP("PXRMETT",$J,VALMCNT,0)),"U"),LEN=$L(USTR)
- S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
- S NAME="" F  S NAME=$O(ARRAY(NAME)) Q:NAME=""  D
- .S VALMCNT=VALMCNT+1
- .S ^TMP("PXRMETT",$J,VALMCNT,0)=USTR_$$LJ^XLFSTR(NAME,36," ")
- .S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
- S VALMCNT=VALMCNT+1
- S ^TMP("PXRMETT",$J,VALMCNT,0)="  "
- S ^TMP("PXRMETT",$J,"IDX",VALMCNT,PLCNT)=""
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Item: "
+ Q
+ ;
+XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
+ N SEL,PLIEN
+ 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 PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
+ ;
+ D START^PXRMLPP(PLIEN)
+ ;
+ S VALMBCK="R"
  Q
  ;
@@ -178,35 +213,5 @@
  .S PLIEN=^TMP("PXRMETT",$J,"SEL",IND)
  .D START^PXRMLPP(PLIEN)
+ ;
  S VALMBCK="R"
  Q
- ;
-PLIST1 ;Toggle list with/without finding totals
- S TOGGLE1=(TOGGLE1+1)#2
- ;Rebuild Workfile
- D BLDLIST(IEN,TOGGLE,TOGGLE1)
- ;Refresh
- S VALMBCK="R",VALMBG=1
- Q
- ;
-XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXTRACT SUMMARY SELECT ENTRY",0))_U_"1:"_VALMCNT
- S XQORM("A")="Select Item: "
- Q
- ;
-XSEL ;PXRM EXTRACT TOTALS SELECT ENTRY validation
- N SEL,PLIEN
- 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 PLIEN=^TMP("PXRMETT",$J,"SEL",SEL)
- D START^PXRMLPP(PLIEN)
- S VALMBCK="R"
- Q
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETX.m	(revision 636)
@@ -1,4 +1,20 @@
-PXRMETX ; SLC/PJH - Run Extract for QUERI ;07/10/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETX ; SLC/PJH - Run Extract for QUERI ;1/22/07  21:25
+ ;;2.0;CLINICAL REMINDERS;**4,7**;Feb 04, 2005;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
 AUTO(ID,PURGE) ;Called from option scheduling (#19.2)
@@ -18,4 +34,6 @@
  ;Purge Patient Lists
  D PRGPL^PXRMETXU
+ ;Call the DOQ-IT HL7 generating routine
+ ;D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"))
  Q
  ;
@@ -53,4 +71,24 @@
  Q
  ;
+ACAD ;Auto CAD entry point
+ D AUTO("VOE DOQ-IT CAD EXTRACTION")
+ Q
+ ;
+ADM ;Auto DM entry point
+ D AUTO("VOE DOQ-IT DM EXTRACTION")
+ Q
+ ;
+AHF ;Auto HF entry point
+ D AUTO("VOE DOQ-IT HF EXTRACTION")
+ Q
+ ;
+AHTN ;Auto HTN entry point
+ D AUTO("VOE DOQ-IT HTN EXTRACTION")
+ Q
+ ;
+APC ;Auto PC entry point
+ D AUTO("VOE DOQ-IT PC EXTRACTION")
+ Q
+ ;
 RUN(IEN,NEXT,MODE,PURGE) ;Process extract parameter
  ; IEN is ien of Extract Parameter
@@ -62,6 +100,5 @@
  ;
  N CLASS,FDA,FDAIEN,MSG
- N PXRMIDOD,PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
- N ITER
+ N PXRMLIST,PXRMNODE,PXRMRULE,PXRMSTRT,PXRMXIEN,PATCREAT,XNAME
  ;Initialise
  K ^TMP("PXRMETX",$J),^TMP("PXRMETX1",$J)
@@ -83,6 +120,4 @@
  ;Determine output name for patient list and extract summary
  S XNAME=NAME_" "_YEAR_" "_PERIOD
- S NAME=$$GETNAME(XNAME)
- S ITER=$P(NAME,"/",2)
  ;Process (single) Denominator rule into patient list
  N SEQ,SUB
@@ -98,18 +133,14 @@
  .S INTP=+$P(DATA,U,5)
  .;Create new patient list
- .I ITER'="" S LIST=LIST_"/"_ITER
- .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRUL1(LIST,CLASS) Q:'PXRMLIST
+ .S PATCREAT="Y",PXRMLIST=$$CRLST^PXRMRULE(LIST,CLASS) Q:'PXRMLIST
  .;
- .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP,ITER)
+ .D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,PXRMSTRT,PXRMSTOP,IEN,YEAR,PERIOD,INDP,INTP)
  .;Clear ^TMP lists created for rule
  .D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
  .;Process reminders and finding rules
- .;If include deceased patients is true then set the flag so reminders
- .;will be evaluated for deceased patients.
- .S PXRMIDOD=$S(INDP:1,1:0)
  .D REM^PXRMETXR(SUB,PXRMLIST,PXRMSTRT,PXRMSTOP,PARTYPE)
  ;
  ;Get the name
- ;S NAME=$$GETNAME(XNAME)
+ S NAME=$$GETNAME(XNAME)
  ;Create extract summary entry
  S FDA(810.3,"+1,",.01)=NAME
@@ -133,4 +164,6 @@
  ;Transmit results
  I (MODE=0)!(MODE=2) D TRANS(FDAIEN(1))
+ ;
+ I $$GET^XPAR("SYS","DOQ-IT")="YES" D EXTRACT^VEPER7EX(VDATA(810.2,IEN_",",3,"I"),VDATA(810.2,IEN_",",5,"I"),PXRMLIST)
  ;
  ;Update extract parameters
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETXR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;02/22/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETXR ; SLC/PJH,PKR - Reminder section of extract ;05/01/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ; Called from PXRMETX
@@ -115,5 +115,5 @@
  ;lists.
  N APPL,DATA,DEFARR,DEFSITE,DFN,DUE,FIEV,FRIEN,FUTIL,IND,INST
- N PXRMDATE,RCNT,REM,REMSEQ,RIEN,RNAM,STATUS,SUB1,TODAY
+ N PXRMDATE,RCNT,REM,RIEN,RNAM,STATUS,SUB1,TODAY
  N END,START
  ;S START=$H
@@ -123,23 +123,20 @@
  ;Scan reminders for this parameter set
  S (RCNT,SUB1)=0
- S REMSEQ=""
- F  S REMSEQ=$O(^PXRM(810.2,IEN,10,SUB,10,"B",REMSEQ)) Q:REMSEQ=""  D
- .F  S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,"B",REMSEQ,SUB1)) Q:'SUB1  D
- ..S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
- ..;Reminder ien
- ..S RIEN=$P(DATA,U,2) Q:'RIEN
- ..;Evaluation date is period end except if the period is incomplete.
- ..S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
- ..;Finding Rule
- ..S FRIEN=$P(DATA,U,3)
- ..;Reminder print name
- ..S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
- ..I RNAM="" S RNAM=$P(^PXD(811.9,RIEN,0),U,1)
- ..;Save details to REM array
- ..S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
- ..;Build list of terms from extract finding rule #810.7
- ..I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
- ..;If no extract finding rule defined collect all findings in reminder
- ..I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
+ F  S SUB1=$O(^PXRM(810.2,IEN,10,SUB,10,SUB1)) Q:'SUB1  D
+ .S DATA=$G(^PXRM(810.2,IEN,10,SUB,10,SUB1,0)) Q:DATA=""
+ .;Reminder ien
+ .S RIEN=$P(DATA,U,2) Q:'RIEN
+ .;Evaluation date is period end except if the period is incomplete.
+ .S PXRMDATE=$S($$FMDIFF^XLFDT(PXRMSTOP,TODAY,2)>0:TODAY,1:PXRMSTOP)
+ .;Finding Rule
+ .S FRIEN=$P(DATA,U,3)
+ .;Reminder print name
+ .S RNAM=$P($G(^PXD(811.9,RIEN,0)),U,3)
+ .;Save details to REM array
+ .S RCNT=RCNT+1,REM(RCNT)=RIEN_U_RNAM_U_FRIEN
+ .;Build list of terms from extract finding rule #810.7
+ .I FRIEN D FRULE(FRIEN,RCNT,SEQ,.REM,.FUTIL) Q
+ .;If no extract finding rule defined collect all findings in reminder
+ .I 'FRIEN D REMF(RIEN,RCNT,SEQ,.REM)
  ;
  ;Process patient list
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETXU.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMETXU.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMETXU.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMETXU ; SLC/PJH - Extract utilities ;09/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMETXU ; SLC/PJH - Extract utilities ;08/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 HELP(CALL) ;General help text routine
@@ -13,33 +13,9 @@
  I CALL=4 D
  .S HTEXT(1)="The selected period is the same as next scheduled extract."
- .S HTEXT(2)="Enter 'Y' if this extract will replace the scheduled"
+ .S HTEXT(2)="Enter 'Y' to if this extract will replace the scheduled"
  .S HTEXT(3)="extract. Enter 'N' if you still want the scheduled extract"
- .S HTEXT(4)="to run."
+ .S HTEXT(3)="to run."
  ;
  D HELP^PXRMEUT(.HTEXT)
- Q
- ;
-DELETE(IEN) ;Delete an extract summary.
- I IEN="" Q
- N DA,DELOK,DIK,NAME
- S DELOK=1
- S NAME=$P(^PXRMXT(810.3,IEN,0),U,1)
- ;Must have PXRM MANAGER key in order to delete national extracts.
- I $P($G(^PXRMXT(810.3,IEN,100)),U,1)="N" D
- . S DELOK=$S($D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
- . I 'DELOK D
- .. W !!,NAME," is national."
- .. W !,"You cannot delete a national extract summary."
- .. H 2
- I 'DELOK Q
- ;Double check the user really wants to delete.
- S TEXT="Are you sure you want to delete "_NAME
- S DELOK=$$ASKYN^PXRMEUT("N","Are you sure you want to delete "_NAME)
- I 'DELOK Q
- S DA=IEN
- S DIK="^PXRMXT(810.3,"
- D ^DIK
- W !,"Deleting ",NAME
- H 2
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEUT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEUT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEUT.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEUT ; SLC/PJH - General extract utilities ;09/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEUT ; SLC/PJH - General extract utilities ;06/27/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;=================================================
@@ -162,11 +162,18 @@
  ;
  ;=================================================
-HELP(HTEXT) ;General help text output routine.
- N IND,NIN,NOUT,TEXTIN,TEXOUT
- ;Make sure the text is in a form the formatting routine can handle.
- S IND="",NIN=0
- F  S IND=$O(HTEXT(IND)) Q:IND=""  S NIN=NIN+1,TEXTIN(NIN)=HTEXT(IND)
- D FORMAT^PXRMTEXT(1,72,NIN,.TEXTIN,.NOUT,.TEXTOUT)
- F IND=1:1:NOUT W !,TEXTOUT(IND)
+HELP(HTEXT) ;General help text routine. Write out the text in the HTEXT
+ ;array.
+ N DIWF,DIWL,DIWR,IC,X
+ S DIWF="C70",DIWL=0,DIWR=70
+ K ^UTILITY($J,"W")
+ S IC=""
+ F  S IC=$O(HTEXT(IC)) Q:IC=""  D
+ . S X=HTEXT(IC)
+ . D ^DIWP
+ W !
+ S IC=0
+ F  S IC=$O(^UTILITY($J,"W",0,IC)) Q:IC=""  D
+ . W !,^UTILITY($J,"W",0,IC,0)
+ K ^UTILITY($J,"W")
  W !
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEUT1.m	(revision 636)
@@ -1,25 +1,11 @@
-PXRMEUT1 ; SLC/PKR - General extract utilities ;05/08/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEUT1 ; SLC/PKR - General extract utilities ;08/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;=================================================
-CLDATES ;Cleanup entries in ^TMP("PXRMDDOC",$J) before making date checks.
- ;For drug findings consolidate PS(55, PS(55NVA, and PSRX( back to
- ;PSDRUG(.
- N FI,FIND0,ITEM,GLOBAL,LIST
- S FIND0=""
- F  S FIND0=$O(^TMP("PXRMDDOC",$J,FIND0)) Q:FIND0=""  D
- . S FI=$P(FIND0,U,1)
- . S GLOBAL=$P(FI,";",2)
- . I GLOBAL'["PS" Q
- . S GLOBAL="PSDRUG("
- . S ITEM=$P(FI,";",1)
- . S FI=ITEM_";"_GLOBAL_U_$P(FIND0,U,2,11)
- . S LIST(FIND0)=FI
- ;
- S FIND0=""
- F  S FIND0=$O(LIST(FIND0)) Q:FIND0=""  D
- . S FI=LIST(FIND0)
- . S ^TMP("PXRMDDOC",$J,FI)=^TMP("PXRMDDOC",$J,FIND0)
- . K ^TMP("PXRMDDOC",$J,FIND0)
- Q
+DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
+ I DATE=0 Q DATE
+ N PXRMDATE
+ S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
+ S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
+ Q $$CTFMD^PXRMDATE(DATE)
  ;
  ;=================================================
@@ -36,17 +22,8 @@
  ;
  ;=================================================
-DCONV(DATE,LBBDT,LBEDT) ;Convert dates to actual values.
- I DATE=0 Q DATE
- N PXRMDATE
- S PXRMDATE=$S(DATE["BDT":LBBDT,1:LBEDT)
- S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
- Q $$CTFMD^PXRMDATE(DATE)
- ;
- ;=================================================
 DOCDATES(RULESET,LBBDT,LBEDT,NL,OUTPUT) ;
- N EM,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
- N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,OPER,PXRMFVPL
+ N FINDPA,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,PXRMDATE,PXRMFVPL
  N RRIEN,RSDATA,RSDATES,RBDT,REDT,SEQ,SUB
- I $G(PXRMDDOC)=2 D CLDATES
  ;Build the variable pointer list.
  D BLDRLIST^PXRMVPTR(811.902,.01,.PXRMFVPL)
@@ -55,6 +32,4 @@
  . S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
  . S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
- . S OPER=$P(RSDATA,U,3)
- . S OPER=$$EXTERNAL^DILFD(810.41,.03,"",OPER,.EM)
  . S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
  .;Finding rule ien.
@@ -69,46 +44,31 @@
  .;Determine RBDT and REDT
  . D RDATES(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
+ . S PXRMDATE=LBEDT
+ . S $P(FINDPA(0),U,8)=RBDT,$P(FINDPA(0),U,11)=REDT
  . S NL=NL+1,OUTPUT(NL)=""
  . S NL=NL+1,OUTPUT(NL)="SEQUENCE "_SEQ_" "_$P(FRDATA,U,1)
- . S NL=NL+1,OUTPUT(NL)=" Operation: "_OPER
  .;Term finding rules
- . I FRTYP=1 D TERM(FRTIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
+ . I FRTYP=1 D TERM(FRTIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
  .;Reminder Definition List Rule
- . I FRTYP=2 D REM(RRIEN,LBBDT,LBEDT,RBDT,REDT,.PXRMFVPL,.NL,.OUTPUT)
+ . I FRTYP=2 D REM(RRIEN,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
  Q
  ;
  ;=================================================
-FMULPRT(FARR,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
+FMULPRT(DEFARR,FINDPA,PXRMFVPL,NL,OUTPUT) ;Print the finding multiple
  ;information.
- ;Q
- N BDT,EDT,DERROR,FNAME,FTYPE,IND,NOCC,TBDT,TEDT,TEMP,VPTR
+ N BDT,EDT,FNAME,FTYPE,IND,NOCC,PFINDPA,TFINDPA,VPTR
  S IND=0
- F  S IND=+$O(FARR(20,IND)) Q:IND=0  D
- . S VPTR=$P(FARR(20,IND,0),U,1)
+ F  S IND=+$O(DEFARR(20,IND)) Q:IND=0  D
+ . S VPTR=$P(DEFARR(20,IND,0),U,1)
  . S FNAME=$$ENTRYNAM^PXRMPTD2(VPTR)
  . S FTYPE=$$FTYPE^PXRMPTD2(VPTR,1)
  . S NL=NL+1,OUTPUT(NL)="  FINDING "_IND_"-"_FTYPE_"."_FNAME
+ . K PFINDPA,TFINDPA
+ . M TFINDPA=DEFARR(20,IND)
  .;Set the finding parameters.
- . D SSPAR^PXRMUTIL(FARR(20,IND,0),.NOCC,.BDT,.EDT)
+ . D SPFINDPA^PXRMTERM(.FINDPA,.TFINDPA,.PFINDPA)
+ . D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  . S NL=NL+1,OUTPUT(NL)="   Beginning Date/Time: "_$$FMTE^XLFDT(BDT,"5Z")
  . S NL=NL+1,OUTPUT(NL)="   Ending Date/Time:    "_$$FMTE^XLFDT(EDT,"5Z")
- . I $G(PXRMDDOC)'=2 Q
- . S DERROR=0
- . S TEMP=$G(^TMP("PXRMDDOC",$J,$P(FARR(20,IND,0),U,1,11)))
- .;If TEMP is null then no evaluation was required and the check 
- .;cannot be made
- . I TEMP="" Q
- . I $P(TEMP,U,1)'=BDT D
- .. S DERROR=1
- .. S NL=NL+1,OUTPUT(NL)="  There is a consistency problem with the beginning date!"
- .. S NL=NL+1,OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")
- . I $P(TEMP,U,2)'=EDT D
- .. S DERROR=1
- .. S NL=NL+1,OUTPUT(NL)="  There is a consistency problem with the ending date!"
- .. S NL=NL+1,OUTPUT(NL)="  Date used to build the list was: "_$$FMTE^XLFDT($P(TEMP,U,2),"5Z")
- . I DERROR D
- .. S NL=NL+1,OUTPUT(NL)="  Please notify the developers."
- .. ;S NL=NL+1,OUTPUT(NL)="  Please enter a Remedy ticket."
- .. S NL=NL+1,OUTPUT(NL)=" "
  Q
  ;
@@ -122,5 +82,5 @@
  I RBDT="" S RBDT=0
  I REDT="" S REDT=LBEDT
- I REDT=0 S REDT=DT
+ I REDT=0 S REDT=$$DT^XLFDT
  ;Convert RBDT and REDT to FileMan dates.
  S RBDT=$$DCONV(RBDT,LBBDT,LBEDT)
@@ -137,19 +97,17 @@
  ;
  ;=================================================
-REM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
+REM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ;
  N DEFARR
  D DEF^PXRMLDR(IEN,.DEFARR)
- D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.DEFARR)
  S NL=NL+1,OUTPUT(NL)=" REMINDER DEFINITION "_$P(DEFARR(0),U,1)
- D FMULPRT(.DEFARR,.PXRMFVPL,.NL,.OUTPUT)
+ D FMULPRT(.DEFARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
  Q
  ;
  ;=================================================
-TERM(IEN,LBBDT,LBEDT,RBDT,REDT,PXRMFVPL,NL,OUTPUT) ;
+TERM(IEN,FINDPA,PXRMFVPL,NL,OUTPUT) ;
  N TERMARR
  D TERM^PXRMLDR(IEN,.TERMARR)
- D DATES^PXRMRUL1(LBBDT,LBEDT,RBDT,REDT,.TERMARR)
  S NL=NL+1,OUTPUT(NL)=" TERM "_$P(TERMARR(0),U,1)
- D FMULPRT(.TERMARR,.PXRMFVPL,.NL,.OUTPUT)
+ D FMULPRT(.TERMARR,.FINDPA,.PXRMFVPL,.NL,.OUTPUT)
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEVFI.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;04/02/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEVFI ; SLC/PKR - Driver for finding evaluation. ;12/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================
@@ -24,5 +24,5 @@
  . I ENODE="PSNDF(50.6," D EVALFI^PXRMDGEN(DFN,.DEFARR,ENODE,.FIEVAL) Q
  . I ENODE="RAMIS(71," D EVALFI^PXRMRAD(DFN,.DEFARR,ENODE,.FIEVAL) Q
- . I ENODE="YTT(601.71," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q
+ . I ENODE="YTT(601," D EVALFI^PXRMMH(DFN,.DEFARR,ENODE,.FIEVAL) Q
  ;Evaluate function findings.
  D EVAL^PXRMFF(DFN,.DEFARR,.FIEVAL)
@@ -38,5 +38,5 @@
  S FINDPA(11)=DEFARR(20,FINUM,11)
  D GENTERM^PXRMPLST(FINDPA(0),FINUM,.TERMARR)
- D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PLIST)
+ D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PLIST)
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXCF.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;06/28/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXCF ; SLC/PKR - Reminder exchange routines for computed findings. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==============================================
 EXISTS(ROUTINE) ;Return true if routine ROUTINE exists.
@@ -10,32 +10,27 @@
  ;==============================================
 GETRACT(ATTR,NEWNAME,NAMECHG,RTN,EXISTS) ;Get the action for a routine.
- N ACTION,CHOICES,CSUM,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
+ N ACTION,CHOICES,DIR,DIROUT,DIRUT,DTOUT,DUOUT,ECS,IND,MSG
  N PCS,ROUTINE,SAME,TEXT,X,Y
  S NEWNAME=""
+ ;If the routine exists compare the existing routine checksum with the
+ ;the checksum of the routine in the packed definition.
  S ROUTINE=ATTR("NAME")
  I EXISTS="" S EXISTS=$$EXISTS^PXRMEXCF(ROUTINE)
  S CHOICES=$S(EXISTS:"COQS",1:"CIQS")
  I EXISTS D
- .;If the routine exists compare the existing routine checksum with the
- .;the checksum of the routine in the packed definition.
- . S CSUM=$$RTNCS^PXRMEXCS(ROUTINE)
- . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
+ . S SAME=$$SAME(.ATTR,.RTN)
  . S TEXT(1)="Routine "_ROUTINE_" already exists "
- . I SAME D
- .. S TEXT(1)=TEXT(1)_"and the packed routine is identical, skipping."
- .. W !,TEXT(1),! H 2
- .. S ACTION="S"
- . I 'SAME D
- .. S TEXT(1)=TEXT(1)_"but the packed routine is different,"
- .. S TEXT(2)="what do you want to do?"
- .. W !,TEXT(1),!,TEXT(2)
- .. S DIR("B")="O"
- .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ . I SAME S TEXT(1)=TEXT(1)_"and the packed routine is identical,"
+ . I 'SAME S TEXT(1)=TEXT(1)_"but the packed routine is different,"
+ . S TEXT(2)="what do you want to do?"
+ . D EN^DDIOL(.TEXT)
+ . S DIR("B")="S"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  E  D
- . W !!,"Routine "_ROUTINE_" is new, what do you want to do?"
+ . W !!,"Routine "_ROUTINE_" is NEW, what do you want to do?"
  . S DIR("B")="I"
  . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  ;
- I (ACTION="Q")!(ACTION="S") Q ACTION
+ I ACTION="Q" Q ACTION
  ;
  I ACTION="C" D
@@ -65,2 +60,17 @@
  Q ACTION
  ;
+ ;==============================================
+SAME(ATTR,RTN) ;Compare the existing routine and the new version
+ ;in RTN to see if they are the same.
+ N ECS,DIF,NEWCS,RT,SAME,X,XCNP
+ ;Load the existing routine into RT.
+ S XCNP=0
+ S DIF="RT("
+ S X=ATTR("NAME")
+ X ^%ZOSF("LOAD")
+ S ECS=$$ROUTINE^PXRMEXCS(.RT)
+ K RT
+ S NEWCS=$$ROUTINE^PXRMEXCS(.RTN)
+ S SAME=$S(ECS=NEWCS:1,1:0)
+ Q SAME
+ ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXCS.m	(revision 636)
@@ -1,50 +1,16 @@
-PXRMEXCS ; SLC/PKR - Routines to compute checksums. ;07/27/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
- ;====================================================
-CHECKSUM(ATTR,START,END) ;Get the the checksum for a packed reminder
- ;component and load it into the attribute array.
- N CS,LINE
- ;If checksum is in packed component return it otherwise calculate it.
- I ATTR("FILE NUMBER")=0 D
- . S LINE=^PXD(811.8,PXRMRIEN,100,START-3,0)
- . S CS=$$GETTAGV^PXRMEXU3(LINE,"<CHECKSUM>")
- . I CS="" S CS=$$PRTNCS(PXRMRIEN,START,END)
- I ATTR("FILE NUMBER")>0 D
- . S LINE=^PXD(811.8,PXRMRIEN,100,START-2,0)
- . S CS=$$GETTAGV^PXRMEXU3(LINE,"<CHECKSUM>")
- . I CS="" S CS=$$PFDACS(PXRMRIEN,START,END)
- S ATTR("CHECKSUM")=CS
- Q
- ;
- ;====================================================
-DIQOUTCS(DIQOUT) ;Return checksum for a processed DIQOUT array.
- N CS,DATA,FIELD,FNUM,IENS,IND,SFN,STRING,TARGET,TEXT,WP
- S FNUM=$O(DIQOUT(""))
- D FIELD^DID(FNUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- S SFN=+$G(TARGET("SPECIFIER"))
- S (CS,FNUM)=0
- F  S FNUM=$O(DIQOUT(FNUM)) Q:FNUM=""  D
- . I FNUM=SFN Q
- . S IENS=""
- . F  S IENS=$O(DIQOUT(FNUM,IENS)) Q:IENS=""  D
- .. S FIELD=0
- .. F  S FIELD=$O(DIQOUT(FNUM,IENS,FIELD)) Q:FIELD=""  D
- ... S DATA=DIQOUT(FNUM,IENS,FIELD)
- ... S TEXT=FNUM_$L(IENS,",")_FIELD_DATA
- ... S CS=$$CRC32^XLFCRC(TEXT,CS)
- ... I DATA["WP-start" F IND=1:1:$P(DATA,"~",2) D
- .... S TEXT=DIQOUT(FNUM,IENS,FIELD,IND)
- .... S CS=$$CRC32^XLFCRC(TEXT,CS)
- Q CS
- ;
+PXRMEXCS ; SLC/PKR - Routines to compute checksums. ;12/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;====================================================
 FILE(FILENUM,IEN) ;Return checksum for entry IEN in file FILENUM.
- N CS,DIQOUT,IENROOT,MSG
- D GETS^DIQ(FILENUM,IEN,"**","N","DIQOUT","MSG")
- ;Remove edit history from all reminder files.
- D RMEH^PXRMEXPU(FILENUM,.DIQOUT,1)
- ;Convert the iens to the FDA adding form.
- D CONTOFDA^PXRMEXPU(.DIQOUT,.IENROOT)
- S CS=$$DIQOUTCS(.DIQOUT)
+ N CS,LC,REF,ROOT,TARGET
+ D FILE^DID(FILENUM,"","GLOBAL NAME","TARGET")
+ S ROOT=$$CREF^DILF(TARGET("GLOBAL NAME"))
+ K ^TMP($J,"PXRMEXCS")
+ M ^TMP($J,"PXRMEXCS")=@ROOT@(IEN)
+ S REF="^TMP($J,""PXRMEXCS"")"
+ S REF=$NA(@REF)
+ S (CS,LC)=0
+ F  S REF=$Q(@REF) Q:REF'["PXRMEXCS"  S LC=LC+1,CS=CS+$$LINECS(LC,@REF)
+ K ^TMP($J,"PXRMEXCS")
  Q CS
  ;
@@ -65,5 +31,14 @@
  N CS,IND,LINE
  S (CS,IND)=0
- F  S IND=$O(@GBL@(IND)) Q:+IND=0  S LINE=@GBL@(IND),CS=$$CRC32^XLFCRC(LINE,CS)
+ F  S IND=$O(@GBL@(IND)) Q:+IND=0  S LINE=@GBL@(IND),CS=CS+$$LINECS(IND,LINE)
+ Q CS
+ ;
+ ;====================================================
+LINECS(LINENUM,STRING) ;Return checksum of line number LINEUM whose contents
+ ;is STRING.
+ N CS,IND,LEN
+ S CS=0
+ S LEN=$L(STRING)
+ F IND=1:1:LEN S CS=CS+($A(STRING,IND)*(LINENUM+IND))
  Q CS
  ;
@@ -73,31 +48,5 @@
  S NLINES=+$P($G(^XMB(3.9,XMZ,2,0)),U,3)
  S CS=0
- F IND=1:1:NLINES S LINE=$G(^XMB(3.9,XMZ,2,IND,0)),CS=$$CRC32^XLFCRC(LINE,CS)
- Q CS
- ;
- ;====================================================
-PFDACS(IEN,FDASTART,FDAEND) ;Return checksum for FDA array of packed
- ;reminder component.
- N CS,DATA,IENS,IND,JND,FIELD,FNUM,SFN,TARGET,TEMP,TEXT
- S TEMP=^PXD(811.8,IEN,100,FDASTART,0)
- S FNUM=$P(TEMP,";",1)
- D FIELD^DID(FNUM,"EDIT HISTORY","","SPECIFIER","TARGET")
- S SFN=+$G(TARGET("SPECIFIER"))
- S CS=0
- F IND=FDASTART:1:FDAEND D
- . S TEMP=^PXD(811.8,IEN,100,IND,0)
- . S DATA=$P(TEMP,"~",2,99)
- . S TEMP=$P(TEMP,"~",1)
- . S FNUM=$P(TEMP,";",1)
- . I FNUM=SFN Q
- . I FNUM="Exchange Stub" Q
- . S IENS=$P(TEMP,";",2)
- . S FIELD=$P(TEMP,";",3)
- . S TEXT=FNUM_$L(IENS,",")_FIELD_DATA
- . S CS=$$CRC32^XLFCRC(TEXT,CS)
- . I DATA["WP-start" F JND=1:1:$P(DATA,"~",2) D
- .. S IND=IND+1
- .. S TEXT=^PXD(811.8,IEN,100,IND,0)
- .. S CS=$$CRC32^XLFCRC(TEXT,CS)
+ F IND=1:1:NLINES S LINE=$G(^XMB(3.9,XMZ,2,IND,0)),CS=CS+$$LINECS(IND,LINE)
  Q CS
  ;
@@ -105,15 +54,11 @@
 ROUTINE(RA) ;Return checksum for a routine loaded in array RA. RA has the
  ;form created by ^%ZOSF("LOAD") i.e, RA(1,0) ... RA(N,0).
- N CS,IND,TEXT
+ N CS,IND,LINE
  S (CS,IND)=0
- ;Get rid of the build number on the second line.
- S RA(2,0)=$P(RA(2,0),";",1,6)
- F  S IND=$O(RA(IND)) Q:+IND=0  D
- . S TEXT=RA(IND,0)
- . S CS=$$CRC32^XLFCRC(RA(IND,0),CS)
+ F  S IND=$O(RA(IND)) Q:+IND=0  S CS=CS+$$LINECS(IND,RA(IND,0))
  Q CS
  ;
  ;====================================================
-RTNCS(ROUTINE) ;Return checksum for a routine ROUTINE.
+RTN(ROUTINE) ;Return checksum for a routine ROUTINE.
  N CS,DIF,RA,X,XCNP
  S XCNP=0
@@ -128,13 +73,2 @@
  Q CS
  ;
- ;====================================================
-PRTNCS(IEN,START,END) ;Return checksum for a packed routine.
- N CS,IND,SL,TEXT
- S CS=0,SL=START+1
- F IND=START:1:END D
- . S TEXT=^PXD(811.8,IEN,100,IND,0)
- . ;Get rid of the build number on the second line.
- . I IND=SL S TEXT=$P(TEXT,";",1,6)
- . S CS=$$CRC32^XLFCRC(TEXT,CS)
- Q CS
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXDG.m	(revision 636)
@@ -1,7 +1,7 @@
-PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;05/16/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXDG ;SLC/PJH - Reminder Dialog Exchange index build ;02/25/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================================
-DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST,SPONLIST) ;
+DIALOG(RIEN,DLIST,FLIST,OLIST,TLIST) ;
  ;
  ;Routine to get dialog details for a given reminder
@@ -27,6 +27,5 @@
  S DCNT=0,FCNT=0,RCNT=0,TCNT=0
  ;Get details
- D GETSPON^PXRMEXPR(801.41,DIEN,.SPONLIST)
- D DGET(DIEN,.SPONLIST)
+ D DGET(DIEN)
  ;
  ;Now build the dialog list (components first)
@@ -41,16 +40,5 @@
  N CNT,COUNT,DTYP
  S COUNT=0
- F DTYP="RESULT ELEMENT" D
- .S CNT=0 F  S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0  D
- ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
- ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
- ;
- F DTYP="RESULT" D
- .S CNT=0 F  S CNT=$O(TEMP(DTYP,CNT)) Q:CNT'>0  D
- ..S DIEN=$G(TEMP(DTYP,CNT)) Q:DIEN'>0
- ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
- ;
- ;F DTYP="RESULT","DIALOG" D
- F DTYP="DIALOG" D
+ F DTYP="RESULT","DIALOG" D
  .F CNT=1:1 S DIEN=$G(TEMP(DTYP,CNT)) Q:'DIEN  D
  ..S COUNT=COUNT+1,DLIST("DIALOG",COUNT,DIEN)=""
@@ -91,16 +79,15 @@
  ;Get the dialog components
  ;-------------------------
-DGET(D0,SPONLIST) ;Save dialog ien
+DGET(D0) ;Save dialog ien
  N D1
  I $G(D0)=83
  I $G(^PXRMD(801.41,D0,49))'="",$P(^PXRMD(801.41,D0,49),U,3)>0 D
- .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0,.SPONLIST) D DGET1(D1,.SPONLIST)
- E  D DGET1(D0,.SPONLIST)
- Q
-DGET1(D0,SPONLIST) ;
+ .S D1=$P($G(^PXRMD(801.41,D0,49)),U,3) D DGET1(D0) D DGET1(D1)
+ E  D DGET1(D0)
+ Q
+DGET1(D0) ;
  S DCNT=DCNT+1,DARRAY(DCNT)=D0
  ;And details (except for reminder dialog)
  I DCNT>1 D
- .D GETSPON^PXRMEXPR(801.41,D0,.SPONLIST)
  .;Finding items
  .D DFIND(D0)
@@ -119,7 +106,7 @@
  .S DDATA=$G(^PXRMD(801.41,DCOMP,0)) Q:DDATA=""
  .;Exclude national PXRM prompts
- .I +$G(PXRMINST)=0,$E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
+ .I $E(DDATA,1,4)="PXRM",$P($G(^PXRMD(801.41,DCOMP,100)),U)="N" Q
  .;Sub-components
- .D DGET(DCOMP,.SPONLIST)
+ .D DGET(DCOMP)
  .;I $G(DCOMP1)'="" D DGET(DCOMP1) S DCOMP1=""
  Q
@@ -175,26 +162,19 @@
  ;---------------------------
 DRESULT(DIEN) ;
- N CNT,RIEN,RECNT,RGCNT
+ N RIEN
  ;Result Group/Element pointer
- S RECNT=$O(TEMP("RESULT ELEMENT",""),-1)
- S RGCNT=$O(TEMP("RESULT",""),-1)
- S CNT=0
- F  S CNT=$O(^PXRMD(801.41,DIEN,51,CNT)) Q:CNT'>0  D
- .S RIEN=$P($G(^PXRMD(801.41,DIEN,51,CNT,0)),U) Q:RIEN'>0
- .;S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN  Q:$D(RESULT(RIEN))
- .;Result group compoments
- .N DSUB,REIEN
- .S DSUB=0
- .F  S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB  D
- ..;Get result element
- ..S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
- ..Q:'$D(^PXRMD(801.41,REIEN,0))
- ..;If element exists get save it
- ..S RECNT=RECNT+1,TEMP("RESULT ELEMENT",RECNT)=REIEN
- ..;S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
- .;
- .;Save result group
- .S RGCNT=RGCNT+1,TEMP("RESULT",RGCNT)=RIEN
- .;S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
+ S RIEN=$P($G(^PXRMD(801.41,DIEN,0)),U,15) Q:'RIEN  Q:$D(RESULT(RIEN))
+ ;Result group compoments
+ N DSUB,REIEN
+ S DSUB=0
+ F  S DSUB=$O(^PXRMD(801.41,RIEN,10,DSUB)) Q:'DSUB  D
+ .;Get result element
+ .S REIEN=$P($G(^PXRMD(801.41,RIEN,10,DSUB,0)),U,2) Q:'REIEN
+ .Q:'$D(^PXRMD(801.41,REIEN,0))
+ .;If element exists get save it
+ .S RCNT=RCNT+1,OUTPUT("RESULT",RCNT)=REIEN
+ ;
+ ;Save result group
+ S RCNT=RCNT+1,RESULT(RIEN)="",TEMP("RESULT",RCNT)=RIEN
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXFI.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;07/05/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXFI ; SLC/PKR/PJH - Exchange utilities for file entries.;12/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==============================================
 DELALL(FILENUM,NAME) ;Delete all file entries named NAME.
@@ -17,20 +17,4 @@
  S DIK=$$ROOT^DILFD(FILENUM)
  D ^DIK
- Q
- ;
- ;==============================================
-FEIMSG(SAME,ATTR) ;Output the general file exits install message.
- N IND,NOUT,TEXT,TEXTO
- S TEXT(1)=ATTR("FILE NAME")_" entry named "_ATTR("NAME")_" already exists"
- I SAME D
- . S TEXT(2)="and the packed component is identical, skipping."
- . S TEXT(3)=" "
- . D FORMAT^PXRMTEXT(1,70,3,.TEXT,.NOUT,.TEXTO)
- . F IND=1:1:NOUT W !,TEXTO(IND)
- . H 2
- I 'SAME D
- . S TEXT(2)="but the packed component is different, what do you want to do?"
- . D FORMAT^PXRMTEXT(1,70,2,.TEXT,.NOUT,.TEXTO)
- . F IND=1:1:NOUT W !,TEXTO(IND)
  Q
  ;
@@ -73,5 +57,4 @@
  ;Mental Health Instruments not allowed.
  I FILENUM=601 Q 0
- I FILENUM=601.71 Q 0
  ;
  I FILENUM=790.404 Q 0
@@ -81,23 +64,19 @@
  ;
  ;==============================================
-GETFACT(PT01,ATTR,NEWPT01,NAMECHG,IEN) ;Get the action for a file.
- N ACTION,CHOICES,CSUM,DIR,FILENUM,MSG,RESULT
- N SAME,X,Y
+GETFACT(PT01,ATTR,NEWPT01,NAMECHG,EXISTS) ;Get the action for a file.
+ N ACTION,CHOICES,DIR,FILENUM,MSG,RESULT,X,Y
  ;See if this entry is already defined.
 CHK ;
  S NEWPT01=""
+ S (ATTR("NAME"),ATTR("PT01"))=PT01
  S FILENUM=ATTR("FILE NUMBER")
- I IEN="" S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
- I IEN D
- .;If the entry already exists compare the existing entry checksum
- .;with the packed entry checksum.
- . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),IEN)
- . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
- . D FEIMSG(SAME,.ATTR)
- . I SAME S ACTION="S"
- . I 'SAME D
- .. S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
- .. S DIR("B")="O"
- .. S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
+ I EXISTS="" S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01)
+ ;Check for identical file entry can be made here.
+ I EXISTS D
+ . W !!,ATTR("FILE NAME")," entry ",PT01," already EXISTS,"
+ . W !,"what do you want to do?"
+ . S CHOICES=$S(FILENUM=801.41:"CMOQS",FILENUM=811.5:"CMOQS",1:"COQS")
+ . S DIR("B")="S"
+ . S ACTION=$$GETACT^PXRMEXIU(CHOICES,.DIR)
  E  D
  . W !!,ATTR("FILE NAME")," entry ",PT01," is NEW,"
@@ -142,5 +121,5 @@
  ;
  ;==============================================
-SETATTR(ATTR,FILE,PT01) ;Set the file attributes for the file FILE.
+SETATTR(ATTR,FILE) ;Set the file attributes for the file FILE.
  N MSG
  S ATTR("FILE NUMBER")=FILE
@@ -149,5 +128,4 @@
  D FIELD^DID(FILE,.01,"","FIELD LENGTH","ATTR","MSG")
  S ATTR("MIN FIELD LENGTH")=3
- S (ATTR("NAME"),ATTR("PT01"))=PT01
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXID.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;08/16/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXID ;SLC/PJH - Reminder Dialog Exchange Install Routine.;11/14/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;==================================================
@@ -7,7 +7,8 @@
  ;------------------------------------------------
 INSALL N ALL,DIROUT,DIRUT,DTOUT,DUOUT,IND,PXRMDONE
+ K ^TMP("PXRMEXIA",$J)
  ;
  ;Set the install date and time.
- S IND="",PXRMDONE=0
+ S IND="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
  ;
  ;Go to full screen mode.
@@ -18,9 +19,10 @@
  S DNAME=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
  D EXIST^PXRMEXIX(.ALL,DNAME,"reminder dialog","")
- I ALL=0 D DISP^PXRMEXLD(PXRMMODE) Q
  ;
  ;Lock the entire file
  Q:'$$LOCK
- F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE)  D
+ ;
+ ;Install all components
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(+IND=0)!(PXRMDONE)  D
  .D INSCOM(IND,1)
  ;
@@ -41,23 +43,7 @@
  F  S ISEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:'ISEQ  D
  .S IDATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,ISEQ)) Q:IDATA=""
- .S DNAME=$P(IDATA,U) Q:DNAME=""
- .;
- .I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D
- ..S REPL=$$CHKREPL^PXRMEXD1(NAME) I REPL>0 D INSREPL(NAME,REPL,.INAME)
- .S INAME(DNAME)=""
- .;Q:$$PXRM(DNAME)  S INAME(DNAME)=""
+ .S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
  .;Check for descendants
  .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
- Q
- ;Build list of replacement names
- ;-------------------------------
-INSREPL(NAME,REPL,INAME) ;
- N DNAME,IDATA,ISEQ
- S ISEQ=0
- S IDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",REPL,NAME)) Q:IDATA=""
- S DNAME=$P(IDATA,U) Q:DNAME=""  S INAME(DNAME)=""
- ;S DNAME=$P(IDATA,U) Q:DNAME=""  Q:$$PXRM(DNAME)  S INAME(DNAME)=""
- ;Check for descendants
- I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) D INSBLD(DNAME,.INAME)
  Q
  ;
@@ -65,6 +51,6 @@
  ;---------------------
 INSCOM(IND,SILENT) ;
- N ACTION,ATTR,CSUM,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
- N NEWPT01,PT01,START,REPL,SAME,TEMP
+ N ACTION,ATTR,DTYP,EXIEN,END,EXISTS,FILENUM,IND120,JND120
+ N NEWPT01,PT01,START,TEMP
  S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),FILENUM=$P(TEMP,U,1)
  S EXISTS=$P(TEMP,U,4),START=$P(TEMP,U,2),END=$P(TEMP,U,3) Q:START=""
@@ -79,6 +65,5 @@
  ;
  ;Check for descendents
- S REPL=$$CHKREPL^PXRMEXD1(PT01)
- I 'SILENT&($$INSDSC(PT01)!(REPL>0)) D  Q:PXRMDONE
+ I 'SILENT,$$INSDSC(PT01) D  Q:PXRMDONE
  .N ANS,INDS,TEXT
  .S TEXT(1)=PT01_" ("_DTYP_") contains sub-components."
@@ -86,9 +71,7 @@
  .;Give option to install all descendents
  .D ASK^PXRMEXIX(.ANS,.TEXT,1) Q:PXRMDONE
- .I $G(ANS)="N" S PXRMDONE=1 Q
  .I $G(ANS)="Y" D
  ..S INDS=IND
  ..N IDATA,INAME,IND
- ..I REPL>0 D INSREPL(PT01,REPL,.INAME)
  ..;Build list of decendents to install
  ..D INSBLD(PT01,.INAME)
@@ -106,21 +89,13 @@
  ...I $D(INAME(PT01)) D INSCOM(IND,1)
  ;
-SETENTRY ;
- D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
- S ACTION=""
+ D SETATTR^PXRMEXFI(.ATTR,FILENUM)
  ;Double check that it hasn't been installed
  S EXIEN=$$EXISTS^PXRMEXIU(801.41,PT01)
  I EXIEN,'EXISTS S EXISTS=1
- I EXISTS D
- . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
- . S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXIEN)
- . S SAME=$S(ATTR("CHECKSUM")=CSUM:1,1:0)
- . I SAME D FEIMSG^PXRMEXFI(SAME,.ATTR) S ACTION="S",(PXRMNMCH,NEWPT01)=""
- I ACTION="" D
- .;If all components installed the default is 'Install or Overwrite'
- . S:ALL ACTION=$S(EXISTS:"O",1:"I"),(PXRMNMCH,NEWPT01)=""
- . S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXIEN)
+ ;If all components installed the default is 'Install or Overwrite'
+ S:ALL ACTION=$S(EXISTS:"O",1:"I"),(ATTR("NAME"),ATTR("PT01"))=PT01,PXRMNMCH="",NEWPT01=""
+ S:'ALL ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
  ;Save what was done for the installation summary.
- S ^TMP("PXRMEXIAD",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
+ S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),ATTR("PT01"),ACTION)=NEWPT01
  ;Clear heading
  S VALMHDR(2)=""
@@ -152,15 +127,7 @@
  F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:'SUB  D  Q:DFOUND
  .S DATA=$G(^TMP("PXRMEXTMP",$J,"DMAP",NAME,SUB)) Q:DATA=""
- .S DFOUND=1
- .;I '$$PXRM($P(DATA,U)) S DFOUND=1
+ .I '$$PXRM($P(DATA,U)) S DFOUND=1
  Q DFOUND
  ;
-INSREPL1(NAME) ;
- N DATA,DFOUND,SUB
- S DFOUND=0,SUB=0
- F  S SUB=$O(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:'SUB  D  Q:DFOUND
- .S DATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",NAME,SUB)) Q:DATA=""
- .S DFOUND=1
- Q DFOUND
  ;Option to link dialog to a reminder
  ;-----------------------------------
@@ -223,6 +190,7 @@
  D EN^VALM2(XQORNOD(0))
  ;
+ K ^TMP("PXRMEXIA",$J)
  ;Set the install date and time.
- S ALL="",PXRMDONE=0
+ S ALL="",PXRMDONE=0,^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
  ;
  ;Lock the entire file
@@ -230,5 +198,6 @@
  ;
  S IND=0
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,0)
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,0)
  ;
  ;Clear locks
@@ -255,17 +224,10 @@
  ;Ignore non-PXRM
  I $E(NAME,1,4)'="PXRM" Q 0
- N DIEN,RESULT
- I $G(PXRMINST)=1 D  Q RESULT
- .S RESULT=0
- .S DIEN=$O(^PXRMD(801.41,"B",NAME,"")) I 'DIEN Q
- .I $P($G(^PXRMD(801.41,DIEN,100)),U)'="N" Q
- .I ($P($G(^PXRMD(801.41,DIEN,0)),U,4)="P")!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="F") S RESULT=1
  ;
  ;Check if this is a national code
+ N DIEN
  S DIEN=$O(^PXRMD(801.41,"B",NAME,""))
  ;If not found abort
  I 'DIEN Q 0
- ;if result group/element quit
- I $P($G(^PXRMD(801.41,DIEN,0)),U,4)="S"!($P($G(^PXRMD(801.41,DIEN,0)),U,4)="T") Q 0
  ;Check class
  I $P($G(^PXRMD(801.41,DIEN,100)),U)="N" Q 1
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIU.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;07/27/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEXIU ; SLC/PKR/PJH - Utilities for installing repository entries. ;06/23/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;===============================================
 DEF(FDA,NAMECHG) ;Check the reminder definition to make sure the related
@@ -47,6 +47,6 @@
  ;
  ;Linked reminder dialog field 51.
- S LRD=$G(FDA(811.9,IENS,51))
- S IEN=$S(LRD="":0,1:+$O(^PXRMD(801.41,"B",LRD,"")))
+ S LRD=+$G(FDA(811.9,IENS,51))
+ S IEN=$$EXISTS^PXRMEXIU(801.41,LRD)
  I IEN=0 K FDA(811.9,IENS,51)
  ;
@@ -198,4 +198,14 @@
  ;
  ;===============================================
+SAME(ATTR,TA,NAME) ;Check existing entry and entry in packed reminder
+ ;definition to see if they are identical.
+ ;Present version only works for computed finding routines, other
+ ;types of entries can be added later.
+ N SAME
+ I ATTR("FILE NAME")="COMPUTED FINDING ROUTINE" S SAME=$$SAME^PXRMEXCF(.ATTR,.TA,NAME)
+ E  S SAME=1
+ Q SAME
+ ;
+ ;===============================================
 TERM(FDA,NAMECHG) ;Check the reminder term to make sure all the
  ;findings exist.
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXIX.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;10/10/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXIX ;SLC/PJH - Reminder Dialog Exchange checks. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================================
@@ -84,8 +84,7 @@
  ...S CNT=CNT+1,FIRST=0,TEXT(CNT)=DNAME_" ("_DTYP_")"
  ..S CNT=CNT+1,TEXT(CNT)=""
- S TEXT="Install "_DTYP_" and all components with no further changes: "
+ S TEXT="Install "_DTYP_" and all components with no further changes:"
  ;Give option to install all descendents
  D ASK(.ANS,.TEXT,2) I $G(ANS)="Y" S ALL=1
- I $G(ANS)="N" S ALL=0
  Q
  ;
@@ -115,9 +114,9 @@
  ;
  I CALL=1 D
- .S HTEXT(1)="Enter 'Yes' to install all sub-components or"
+ .S HTEXT(1)="Enter 'Yes' to if you are installing all sub-components or"
  .S HTEXT(2)="enter 'No' to install only the selected dialog."
  I CALL=2 D
- .S HTEXT(1)="Enter 'Yes' to install without changes."
- .S HTEXT(2)="Enter 'No' to install with changes."
+ .S HTEXT(1)="Enter 'Yes' to if you are installing without changes."
+ .S HTEXT(2)="enter 'No' to install with changes."
  I CALL=3 D
  .S HTEXT(1)="Select IFE to INSTALL reminder or dialog from this exchange"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLB.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;05/16/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXLB ;SLC/PJH - Reminder Dialog Exchange. ;07/01/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================================
@@ -7,6 +7,5 @@
  ;-------------------------------
 DBUILD(IND,NITEMS,FILENUM) ;
- N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,FILE,JND
- N REPCNT,RESGRP,TEMPRESL,CNT
+ N DARRAY,DDATA,DDLG,DEND,DLOC,DMAP,DNAM,DNODE,DSEQ,DSTRT,DSUB,JND
  ;
  K ^TMP("PXRMEXTMP",$J),^TMP("PXRMEXFND",$J)
@@ -20,5 +19,5 @@
  .D DPARSE
  ;Scan dialog components in 120 and save dialog links
- S JND="B",REPCNT=0
+ S JND="B"
  F  S JND=$O(^PXD(811.8,IEN,120,IND,1,JND),-1) Q:'JND  D
  .S DDATA=$G(^PXD(811.8,IEN,120,IND,1,JND,0)) Q:DDATA=""
@@ -31,6 +30,5 @@
  .F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:DSUB>DEND  D
  ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB,0))
- ..I ($P(DNODE,";")'="801.412")&($P(DNODE,";")'="801.41121")&($P(DNODE,";",3)'["118~") Q
- ..S FILE=$P(DNODE,";")
+ ..I $P(DNODE,";")'="801.412"&($P(DNODE,";",3)'["118~") Q
  ..S DNODE=$P(DNODE,";",3)
  ..;;Modified Exchange to handle dialogs with replacement dialogs
@@ -38,15 +36,8 @@
  ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
  ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
- ...S REPCNT=REPCNT+1,^TMP("PXRMEXTMP",$J,"DREPL",REPCNT,DDLG)=DNAM_U_DLOC
+ ...S ^TMP("PXRMEXTMP",$J,"DREPL",DDLG)=DNAM_U_DLOC
  ..I $E(DNODE,1,4)'=".01~" Q
  ..S DSEQ=$P(DNODE,"~",2) Q:DSEQ=""
- ..I FILE="801.41121" D  Q
- ...S DNAM=$P(DNODE,"~",2) Q:DNAM=""
- ...S DLOC=$G(^TMP("PXRMEXTMP",$J,"DLOC",DNAM))
- ...S CNT=0
- ...I $D(^TMP("PXRMEXTMP",$J,"DMAP",DDLG))>0 S CNT=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
- ...S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,CNT+1)=DNAM_U_DLOC
- ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB+1,0))
- ..I ($P(DNODE,";")'="801.412") Q
+ ..S DNODE=$G(^PXD(811.8,IEN,100,DSUB+1,0)) I $P(DNODE,";")'="801.412" Q
  ..S DNODE=$P(DNODE,";",3) I $E(DNODE,1,2)'="2~" Q
  ..S DNAM=$P(DNODE,"~",2) Q:DNAM=""
@@ -55,4 +46,6 @@
  ;
  ;Build index of dialog findings by name
+ ;
+ ;
  N FDATA,FILENAM,FILENUM,FNAME
  S IND=0
@@ -71,9 +64,4 @@
  ..;Save entry
  ..S ^TMP("PXRMEXFND",$J,FNAME)=FILENUM_U_FILENAM_U_IND
- I $D(TEMPRESL)>0 D
- .S DDLG="" F  S DDLG=$O(TEMPRESL(DDLG)) Q:DDLG=""  D
- ..;S ^TMP("PXRMEXTMP",$J,"RESULT",DDLG,TEMPRESL(DDLG))=""
- ..S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DDLG,""),-1)
- ..S ^TMP("PXRMEXTMP",$J,"DMAP",DDLG,DSEQ+1)=TEMPRESL(DDLG)_U_RESGRP(TEMPRESL(DDLG))
  Q
  ;
@@ -83,7 +71,6 @@
  ;
  ;Find where all the field numbers are kept
- N DARRAY,DDATA,DFNUM,DRAW,DSTRING,RESNAM
- S DSUB=DSTRT-1,DSTRING=";.01;4;5;15;24;25;55;"
- ;S DSUB=DSTRT,DSTRING=";4;5;15;24;25;"
+ N DARRAY,DDATA,DFNUM,DRAW,DSTRING
+ S DSUB=DSTRT,DSTRING=";4;5;15;24;25;"
  F  S DSUB=$O(^PXD(811.8,IEN,100,DSUB)) Q:'DSUB  D  Q:DSUB>DEND
  .S DDATA=$G(^PXD(811.8,IEN,100,DSUB,0)) Q:DDATA=""
@@ -91,15 +78,14 @@
  .S DFNUM=$P(DDATA,";",3),DFNUM=$P(DFNUM,"~") Q:DFNUM=""
  .I DSTRING[(";"_DFNUM_";") S DARRAY(DFNUM)=DSUB
- .I $P(DDATA,";")="801.41121" S DARRAY(55)=DSUB
  ;
  ;Determine dialog component type
  S DSUB=DARRAY(4) Q:'DSUB
  S DTYP=$P($G(^PXD(811.8,IEN,100,DSUB,0)),"~",2)
- I DTYP'["result" S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
+ S:DTYP[" " DTYP=$P(DTYP," ",2) S:DTYP="value" DTYP="forced"
  ;
  ;Initialise text and finding fields
  S DTXT="*NONE*",DFIND=""
  ;Get text appropriate for the type of component
- I ((DTYP="element")!(DTYP="group"))&(DTYP'["result") D
+ I (DTYP="element")!(DTYP="group") D
  .;search for WP text
  .S DSUB=$G(DARRAY(25)) D:DSUB
@@ -115,8 +101,5 @@
  ..;Reformat text to 50 characters
  ..D DWP(.DTXT)
- ..;Search for Result Group/Element
- ..S DSUB=$G(DARRAY(55)) I DSUB>0 D
- ...S RESNAME=$P($P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3),"~",2)
- ...S TEMPRESL(DNAM)=RESNAME
+ .;
  .;Search for finding item
  .S DSUB=$G(DARRAY(15)) D:DSUB
@@ -136,10 +119,4 @@
  ...I $P(DFNAM,".")="ICD9" S DFNAM=$P(DFNAM," ")
  ...S DCNT=DCNT+1,DFIAD(DCNT)=DFNAM
- ;
- I DTYP["result" D
- .S DSUB=$G(DARRAY(.01)) Q:'DSUB
- .S DTEXT=$P($G(^PXD(811.8,IEN,100,DSUB,0)),";",3) Q:DTEXT=""
- .S DTXT=$P(DTEXT,"~",2)
- .S RESGRP(DNAM)=DSTRT_U_DEND_U_IND_U_JND
  ;
  I DTYP="prompt" D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLC.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXLC ; SLC/PKR/PJH - Routines to display repository entry components. ;08/03/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEXLC ; SLC/PKR/PJH - Routines to display repository entry components. ;06/22/2004
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;======================================================
 BLDLIST(FORCE) ;Build a list of all repository entries.
@@ -7,6 +7,9 @@
  I $D(^TMP("PXRMEXLR",$J,"VALMCNT")) S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
  E  D
- . D REXL^PXRMLIST("PXRMEXLR")
- . S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
+ . N IEN,RELIST
+ . D RE^PXRMLIST(.RELIST,.IEN)
+ . M ^TMP("PXRMEXLR",$J)=RELIST
+ . S VALMCNT=RELIST("VALMCNT")
+ . F IND=1:1:VALMCNT S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
  Q
  ;
@@ -76,4 +79,20 @@
  ;
  ;======================================================
+DDISP(IND,NITEMS,FILENUM) ;Setup dialog display list.
+ N JND,NLINE,NSEL,TEMP
+ S (NLINE,NSEL)=0
+ F JND=1:1:NITEMS D
+ . S TEMP=^PXD(811.8,IEN,120,IND,1,JND,0)
+ . S PT01=$P(TEMP,U,1)
+ . S EXISTS=$$EXISTS^PXRMEXIU(FILENUM,PT01,"W")
+ . S NLINE=NLINE+1
+ . S NSEL=NSEL+1
+ . S ^TMP("PXRMEXLD",$J,NLINE,0)=$$FMTDATA(NSEL,PT01,CAT,EXISTS)
+ . S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;Store the file number, start and stop line in the repository.
+ . S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_$P(TEMP,U,2,3)
+ Q
+ ;
+ ;======================================================
 FMTDATA(NSEL,PT01,CAT,EXISTS) ;Format items for display.
  N NSTI,TEMP
@@ -88,4 +107,50 @@
  ;
  ;======================================================
+HISTLIST(LIST,VALMCNT) ;Build a list of install histories in
+ ;^TMP("PXRMEXIH",$J).
+ N DATE,DC,ENTRY,IHIND,IND,INDONE,NLINE,NSEL,RIEN,SOURCE,TEMP,USER
+ K ^TMP("PXRMEXIH",$J)
+ S (NLINE,NSEL)=0
+ S IND=""
+ F  S IND=$O(LIST(IND)) Q:IND=""  D
+ . S RIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
+ . I $D(^PXD(811.8,RIEN,130)) S INDONE=1
+ . E  S INDONE=0
+ . S TEMP=^PXD(811.8,RIEN,0)
+ . S ENTRY=$P(TEMP,U,1)
+ . S SOURCE=$P(TEMP,U,2)
+ . S DATE=$P(TEMP,U,3)
+ . S NLINE=NLINE+1
+ . I INDONE S NSEL=NSEL+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)=$$FRE^PXRMLIST(" ",ENTRY,SOURCE,DATE)
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)="     Installation Date       Installed By"
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)="     -----------------       ------------"
+ . I INDONE S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ . I 'INDONE D  Q
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)="      none"
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)=" "
+ . S DATE="",DC=0
+ . F  S DATE=$O(^PXD(811.8,RIEN,130,"B",DATE)) Q:DATE=""  D
+ .. S NLINE=NLINE+1
+ .. S DC=DC+1
+ .. I DC>1 S NSEL=NSEL+1
+ .. S IHIND=$O(^PXD(811.8,RIEN,130,"B",DATE,""))
+ .. S TEMP=^PXD(811.8,RIEN,130,IHIND,0)
+ .. S ^TMP("PXRMEXIH",$J,NLINE,0)=$$RJ^XLFSTR(NSEL,4," ")_" "_$$FMTE^XLFDT($P(TEMP,U,1),"5Z")_"   "_$P(TEMP,U,2)
+ .. S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ .. S ^TMP("PXRMEXIH",$J,"SEL",NSEL)=RIEN_U_IHIND
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXIH",$J,NLINE,0)=" "
+ . S ^TMP("PXRMEXIH",$J,"IDX",NLINE,NSEL)=""
+ S VALMCNT=NLINE
+ Q
+ ;
+ ;======================================================
 INSCHR(NUM,CHR) ;Return a string of NUM characters (CHR).
  N IND,TEMP
@@ -96,10 +161,32 @@
  ;
  ;======================================================
-ORDER(STRING,ORDER) ;Rebuild string in ascending or descending order.
- N ARRAY,ITEM,CNT
- F CNT=1:1 S ITEM=$P(STRING,",",CNT) Q:'ITEM  S ARRAY(ITEM)=""
- K STRING
- F CNT=1:1 S ITEM=$O(ARRAY(ITEM),ORDER) Q:'ITEM  D
- .S $P(STRING,",",CNT)=ITEM
+DREPL ;
+ N STR,I
+ K PXRMEXOR
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ S STR="" F I=1:1:30 S STR=STR_"-"
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J(STR_" REPLACEMENT ITEMS "_STR,79)
+DREPL1 ;
+ M ^TMP($J,"PXRMEXREP")=PXRMEXRP
+ K PXRMEXRP
+ ;S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)="
+ N CNT,DLG,DDATA,DDLG,DEND,DNAM,DREP,DSTRT,IND,JND,LEV,TEMP
+ ;S LEV="" F  S LEV=$O(^TMP($J,"PXRMEXREP",LEV)) Q:LEV=""  D
+ S LEV=0
+ S DLG="" F  S DLG=$O(^TMP($J,"PXRMEXREP",DLG)) Q:DLG=""  D
+ .S DDATA=$G(^TMP("PXRMEXTMP",$J,"DREPL",DLG)) Q:DDATA=""
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ .I $D(PXRMEXOR(DNAM))>0 Q
+ .S PXRMEXOR(DNAM)=""
+ .S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Check if this component has been replaced
+ .S LEV=LEV+1
+ .S DREP=$G(PXRMNMCH(FILENUM,DNAM)) I DREP=DNAM S DREP=""
+ .;Save line in workfile
+ .S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ .S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .D DLINE^PXRMEXLD(DNAM,LEV,"")
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP^PXRMEXLD(DNAM,LEV)
+ K ^TMP($J,"PXRMEXREP")
+ I $D(PXRMEXRP)>0 D DREPL1
  Q
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLD.m	(revision 636)
@@ -1,36 +1,76 @@
-PXRMEXLD ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;08/07/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
- ;
+PXRMEXLD ;SLC/PJH - Reminder Dialog Exchange Main Routine. ;7/01/2004
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;=====================================================================
 START N PXRMBG,PXRMMODE,VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ
  S X="IORESET"
  D EN^VALM("PXRM EX LIST DIALOG")
+ ;
  ;Rebuild Display
  D CDISP^PXRMEXLC(PXRMRIEN)
  Q
  ;
-ENTRY ; Entry point for List Manager
- D FIND Q
- ;
-DETAIL ;Detailed display
- S PXRMMODE=0 D DISP(PXRMMODE) Q
- ;
-FIND ;Display findings
- S PXRMMODE=2 D DISP(PXRMMODE) Q
- ;
-SUM ;Display dialog summary
- S PXRMMODE=3 D DISP(PXRMMODE) Q
- ;
-USE ;Display dialog usage
- S PXRMMODE=4 D DISP(PXRMMODE) Q
- ;
-TEXT ;Display dialog text
- S PXRMMODE=1 D DISP(PXRMMODE) Q
- ;
-EXIT ;
+ENTRY D FIND Q
+ ;
+DETAIL S PXRMMODE=0 D DISP(PXRMMODE) Q
+ ;
+ ;Display Findings
+ ;--------------------------
+FIND S PXRMMODE=2 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Summary
+ ;----------------------
+SUM S PXRMMODE=3 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Usage
+ ;--------------------
+USE S PXRMMODE=4 D DISP(PXRMMODE) Q
+ ;
+ ;Display Dialog Text
+ ;-------------------
+TEXT S PXRMMODE=1 D DISP(PXRMMODE) Q
+ ;
+EXIT K ^TMP("PXRMEXLD",$J) Q
+ ;
+PEXIT ;PXRM EXCH DIALOG MENU protocol exit code
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+HELP N ORU,ORUPRMT,XQORM,PXRMTAG S PXRMTAG="DLG"
+ D EN^VALM("PXRM EX DIALOG HELP")
+ Q
+ ;
+HDR S VALMHDR(1)="Packed reminder dialog: "
+ S VALMHDR(1)=VALMHDR(1)_$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
+ I $D(^TMP("PXRMEXTMP",$J,"PXRMDNAT")) D
+ .S VALMHDR(1)=VALMHDR(1)_" [NATIONAL DIALOG]"
+ S VALMHDR("TITLE")=VALMHDR(1)
+ S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
+ Q
+ ;
+ ;Build list manager workfile from ^TMP("PXRMEXTMP" (see ^PXRMEXLB)
+DISP(VIEW) ;
+ N OLEV,ODSEQ
  K ^TMP("PXRMEXLD",$J)
- Q
- ;
-DISP(VIEW) ;Build the requested view and display it.
- D BLDDISP^PXRMEXD1(VIEW)
+ K PXRMEXRP
+ K ^TMP($J,"PXRMEXREP")
+ N DDATA,DDLG,DEND,DREP,DSTRT,IND,JND,NLINE,NSEL
+ S NLINE=0,NSEL=0,VALMBCK="R",VALMCNT=NLINE
+ S DDLG=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) Q:DDLG=""
+ ;
+ ;Save reminder dialog
+ S DDATA=^TMP("PXRMEXTMP",$J,"DLOC",DDLG)
+ S DSTRT=$P(DDATA,U,1),DEND=$P(DDATA,U,2)
+ S IND=$P(DDATA,U,3),JND=$P(DDATA,U,4),DREP=""
+ D DLINE(DDLG,"","")
+ S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;Process componentS
+ D DCMP(DDLG,"")
+ ;Process replacement elements
+ ;I $D(^TMP("PXRMEXTMP",$J,"DREPL"))>0 D DREPL^PXRMEXLC
+ I $D(PXRMEXRP)>0 D DREPL^PXRMEXLC
  ;Change header
  I VIEW=0 D CHGCAP^VALM("HEADER2","Dialog Details")
@@ -39,30 +79,179 @@
  I VIEW=3 D CHGCAP^VALM("HEADER2","Dialog Summary")
  I VIEW=4 D CHGCAP^VALM("HEADER2","Dialog Usage")
- S VALMCNT=^TMP("PXRMEXLD",$J,"VALMCNT"),VALMBG=1,VALMBCK="R"
+ ;
+ S VALMCNT=NLINE,^TMP("PXRMEXLD",$J,"VALMCNT")=VALMCNT,VALMBG=1
+ ;
+ K ^TMP($J,"PXRMEXREP"),PXRMEXRP
  ;Reset protocol
  D XQORM
  Q
  ;
-HELP ;
- N ORU,ORUPRMT,XQORM,PXRMTAG
- S PXRMTAG="DLG"
- D EN^VALM("PXRM EX DIALOG HELP")
- Q
- ;
-HDR ;
- S VALMHDR(1)="Packed reminder dialog: "
- S VALMHDR(1)=VALMHDR(1)_$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM"))
- I $D(^TMP("PXRMEXTMP",$J,"PXRMDNAT")) S VALMHDR(1)=VALMHDR(1)_" [NATIONAL DIALOG]"
- S VALMHDR("TITLE")=VALMHDR(1)
- S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- Q
- ;
-PEXIT ;PXRM EXCH DIALOG MENU protocol exit code
- S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- ;Reset after page up/down etc
- D XQORM
- Q
- ;
-VALID(STRING) ;Validate sequence numbers
+ ;Update workfile
+DLINE(DNAM,LEV,DSEQ) ;
+ ;Check if standard PXRM prompt
+ N LEVSEQ,TLEV
+ N DPXRM S DPXRM=$$PXRM^PXRMEXID(DNAM)
+ ;
+ ;Ignore PXRM prompts if doing a finding view (DF)
+ I VIEW>1,DPXRM Q
+ ;
+ N DEXIST,DPTX,DTXT,DTYP,EXIST,ITEM,TEMP,SEP
+ S ITEM=""
+ I DPXRM=0 S NSEL=NSEL+1,ITEM=NSEL
+ S NLINE=NLINE+1,SEP=$E(LEV,$L(LEV)),DEXIST=0
+ S LEVSEQ=LEV_DSEQ
+ S TEMP=$J(ITEM,3)_$J("",4)_LEV_DSEQ
+ ;Determine type
+ S DTYP=$G(^TMP("PXRMEXTMP",$J,"DTYP",DNAM))
+ ;Dialog component display
+ I (VIEW'=1) D
+ .I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DNAM,1,50)
+ .E  S TEMP=TEMP_" "_$E(DNAM,1,50)
+ I VIEW=1 D
+ .I DTYP]"" S DTXT=$G(^TMP("PXRMEXTMP",$J,"DTXT",DNAM))
+ .I DTYP="" S DTXT=DNAM
+ .I DREP'="" S DTXT=DNAM
+ .I $L(TEMP)<13 S TEMP=TEMP_$J("",12+$L(SEP)-$L(TEMP))_$E(DTXT,1,50)
+ .E  S TEMP=TEMP_" "_$E(DTXT,1,50)
+ ;Check for replacements
+ I $D(^TMP("PXRMEXTMP",$J,"DREPL",DNAM))>0 D
+ .S TEMP=TEMP_"*"
+ .S TLEV=$S($E(LEVSEQ,$L(LEVSEQ))=".":$E(LEVSEQ,1,$L(LEVSEQ)-1),1:LEVSEQ)
+ .S PXRMEXRP(DNAM)=""
+ .;S ^TMP($J,"PXRMEXREP",TLEV,DNAM)=""
+ ;Add Type
+ S TEMP=TEMP_$J("",65-$L(TEMP))_DTYP
+ ;Exists flag
+ I DPXRM=0,$$EXISTS^PXRMEXIU(801.41,DNAM) D
+ .S TEMP=TEMP_$J("",75-$L(TEMP))_"X",DEXIST=1
+ S ^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ;
+ ;Set up selection index
+ S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)="" Q:DPXRM=1
+ ;Store the file number, start and stop line in the exchange file.
+ S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_DSTRT_U_DEND_U_DEXIST_U_IND_U_JND
+ ;Insert additional text lines
+ I VIEW=1,DREP="" D
+ .N DSUB,DTXT,FILENUM
+ .S DSUB=0,FILENUM=8927.1
+ .F  S DSUB=$O(^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)) Q:'DSUB  D
+ ..S DTXT=$G(^TMP("PXRMEXTMP",$J,"DTXT",DNAM,DSUB)),NLINE=NLINE+1
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_$E(DTXT,1,50)
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;TIU template changes
+ .I $D(PXRMNMCH(FILENUM)),$D(^TMP("PXRMEXTMP",$J,"DTIU",DNAM)) D
+ ..N TEMP,TNAM,TNNAM
+ ..S TNAM=""
+ ..F  S TNAM=$O(^TMP("PXRMEXTMP",$J,"DTIU",DNAM,TNAM)) Q:TNAM=""  D
+ ...S TNNAM=$G(PXRMNMCH(FILENUM,TNAM)) Q:TNNAM=""
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ...S TEMP=$J("",12+$L(SEP))_"(TIU template "_TNAM_" copied to "_TNNAM_")"
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ...S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;Insert finding items
+ I VIEW=2,("element;group"[DTYP),DREP="" D
+ .N DSUB,FDATA,FILENUM,FLIT,FLONG,FNAME,FOUND,FREP,FTAB,FTYP,TEMP
+ .;Findings and additional findings
+ .S DSUB=0,FOUND=0
+ .F  S DSUB=$O(^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB)) Q:'DSUB  D
+ ..S FNAME=$G(^TMP("PXRMEXTMP",$J,"DFND",DNAM,DSUB)) Q:FNAME=""
+ ..S FDATA=$G(^TMP("PXRMEXFND",$J,FNAME))
+ ..S FILENUM=$P(FDATA,U),FTYP=$P(FDATA,U,2) Q:'FILENUM
+ ..S FREP=$G(PXRMNMCH(FILENUM,FNAME)) I FREP=FNAME S FREP=""
+ ..S NLINE=NLINE+1,EXIST=$$EXISTS^PXRMEXIU(FILENUM,FNAME),FOUND=1
+ ..I DSUB=1 S FLIT="Finding: "
+ ..I DSUB>1 S FLIT="Add. Finding: "
+ ..S FLONG=0 I $L(FLIT_FNAME_" ("_FTYP_")")>60 S FLONG=1
+ ..I 'FLONG S FNAME=FLIT_FNAME_" ("_FTYP_")"
+ ..I FLONG S FNAME=FLIT_FNAME
+ ..S TEMP=$J("",12+$L(SEP))_$E(FNAME,1,60)_$J("",60-$L(FNAME))
+ ..I EXIST S TEMP=TEMP_$J("",75-$L(TEMP))_"X"
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=TEMP
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ..I FLONG D
+ ...S NLINE=NLINE+1
+ ...S FTAB=$S(DSUB=1:21,1:26)
+ ...S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",FTAB)_"("_FTYP_")"
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ..I FREP'="" D
+ ...S NLINE=NLINE+1
+ ...S FTAB=$S(DSUB=1:21,1:26)
+ ...S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",FTAB)_"(Replaced by "_FREP_")"
+ ...S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ .;If no findings
+ .I 'FOUND D
+ ..S NLINE=NLINE+1
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_"Finding: *NONE*"
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ ;
+ ;Usage screen
+ I VIEW=4,DREP="" D
+ .N DOTHER,DTXT,DTYPE,OTHER,TYPE
+ .D OTHER(DNAM,.DOTHER) Q:'$D(DOTHER)
+ .S OTHER=""
+ .F  S OTHER=$O(DOTHER(OTHER)) Q:OTHER=""  D
+ ..S TYPE=DOTHER(OTHER),NLINE=NLINE+1,DTYPE="REMINDER DIALOG"
+ ..I TYPE="G" S DTYPE="DIALOG GROUP"
+ ..I TYPE="E" S DTYPE="DIALOG ELEMENT"
+ ..S DTXT="USED BY: "_OTHER_" ("_DTYPE_")"
+ ..S ^TMP("PXRMEXLD",$J,NLINE,0)=$J("",12+$L(SEP))_DTXT
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;Save details of dialog components for display
+DCMP(DLG,LEV) ;
+ N DDATA,DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND,LAST,LEVSEQ,NUM
+ S DSEQ=0,LAST=0
+ F  S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)) Q:'DSEQ  D
+ .S DDATA=^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)
+ .S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ .S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Check if this component has been replaced
+ .S DREP=$G(PXRMNMCH(FILENUM,DNAM)) I DREP=DNAM S DREP=""
+ .;Save line in workfile
+ .S NUM=DSEQ
+ .;S NUM=$S($G(REPL)["R":"."_DSEQ,1:DSEQ)
+ .I +LEV>0,NUM>0,$E(LEV,$L(LEV))'="." S LEV=LEV_"."
+ .D DLINE(DNAM,LEV,NUM) Q:DREP'=""
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM,LEV_DSEQ_".")
+ .;Extra line feed
+ .I LEV="" D
+ ..S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ ..S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ I $G(REPL)["R" D
+ .S NLINE=NLINE+1,^TMP("PXRMEXLD",$J,NLINE,0)=$J("",79)
+ .S ^TMP("PXRMEXLD",$J,"IDX",NLINE,NSEL)=""
+ Q
+ ;
+ ;Rebuild string in ascending or descending order
+ORDER(STRING,ORDER) ;
+ N ARRAY,ITEM,CNT
+ F CNT=1:1 S ITEM=$P(STRING,",",CNT) Q:'ITEM  S ARRAY(ITEM)=""
+ K STRING
+ F CNT=1:1 S ITEM=$O(ARRAY(ITEM),ORDER) Q:'ITEM  D
+ .S $P(STRING,",",CNT)=ITEM
+ Q
+ ;
+ ;Check if used by other dialogs
+OTHER(NAME,LIST) ;
+ N DDATA,DIEN,DNAME,DTYP,IEN
+ S IEN=$O(^PXRMD(801.41,"B",NAME,0)) Q:'IEN
+ ;Check if used by other dialogs
+ I '$D(^PXRMD(801.41,"AD",IEN)) Q
+ ;Build list of dialogs using this component
+ S DIEN=0
+ F  S DIEN=$O(^PXRMD(801.41,"AD",IEN,DIEN)) Q:'DIEN  D
+ .S DDATA=$G(^PXRMD(801.41,DIEN,0)) Q:DDATA=""
+ .S DNAME=$P(DDATA,U),DTYP=$P(DDATA,U,4) Q:DNAME=""
+ .;Include only dialogs that are not part of this reminder dialog
+ .I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAME)) Q
+ .S LIST(DNAME)=DTYP
+ Q
+ ;
+ ;Validate sequence numbers
+VALID(STRING) ;
  N CNT,FOUND,OK
  S FOUND=0,OK=1
@@ -86,5 +275,5 @@
  ;
  ;Sort the SELECTION into reverse order
- D ORDER^PXRMEXLC(.SELECT,-1)
+ D ORDER(.SELECT,-1)
  ;
  ;Lock the file
@@ -99,4 +288,5 @@
  D UNLOCK^PXRMEXID
  ;
+ ;
  ;Rebuild Workfile
  D DISP^PXRMEXLD(PXRMMODE)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLI.m	(revision 636)
@@ -1,8 +1,11 @@
-PXRMEXLI ; SLC/PKR - List Manager routines for repository entry install. ;08/08/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXLI ; SLC/PKR - List Manager routines for repository entry install. ;01/10/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;================================================
 INSALL ;Install all components in a repository entry.
  N IND,INSTALL
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
  ;Initialize the name change storage.
  K PXRMNMCH
@@ -46,5 +49,4 @@
  I FILENUM=0 D
  . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
- . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
  . S ACTION=$$GETRACT^PXRMEXCF(.ATTR,.NEWNAME,.PXRMNMCH,.RTN,EXISTS)
  .;Save what was done for the installation summary.
@@ -56,6 +58,5 @@
  . I FIELDNUM=.001 S TEMP=^PXD(811.8,PXRMRIEN,100,(START+1),0)
  . S PT01=$P(TEMP,"~",2)
- . D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
- . D CHECKSUM^PXRMEXCS(.ATTR,START,END)
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM)
  . S ACTION=$$GETFACT^PXRMEXFI(PT01,.ATTR,.NEWPT01,.PXRMNMCH,EXISTS)
  .;Save what was done for the installation summary.
@@ -90,8 +91,13 @@
  I '$D(VALMY) Q
  ;
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
+ S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
+ ;
  ;Initialize the name change storage.
  K PXRMNMCH
  S (IND,INSTALL)=0
- F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D INSCOM(IND,.INSTALL)
+ F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
+ .D INSCOM(IND,.INSTALL)
  ;
  ;If anything was installed rebuild the display.
@@ -109,8 +115,4 @@
  I '$D(^PXD(811.8,PXRMRIEN,120)) D CLIST^PXRMEXU1(.PXRMRIEN)
  I PXRMRIEN=-1 Q
- K ^TMP("PXRMEXIA",$J),^TMP("PXRMEXIAD",$J)
- ;Set the install date and time and type.
- S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
- S ^TMP("PXRMEXIA",$J,"TYPE")="INTERACTIVE"
  ;Format the component list for display.
  D CDISP^PXRMEXLC(PXRMRIEN)
@@ -120,5 +122,4 @@
  Q
  ;
- ;================================================
  ;Exit action added to PXRM EXCH INSTALL MENU
 PEXIT ;PXRM EXCH INSTALL MENU protocol exit code
@@ -128,10 +129,8 @@
  Q
  ;
- ;================================================
 XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT COMPONENT",0))_U_"1:"_VALMCNT
  S XQORM("A")="Select Action: "
  Q
  ;
- ;================================================
 XSEL ;PXRM EXCH SELECT COMPONENT validation
  N CNT,SELECT,SEL,PXRMDONE
@@ -140,10 +139,9 @@
  ;
  ;Sort selections into ascending sequence order
- D ORDER^PXRMEXLC(.SELECT,1)
+ D ORDER^PXRMEXLD(.SELECT,1)
  ;
- K ^TMP("PXRMEXIA",$J),^TMP("PXRMEXIAD",$J)
- ;Set the install date and time and type.
+ K ^TMP("PXRMEXIA",$J)
+ ;Set the install date and time.
  S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
- S ^TMP("PXRMEXIA",$J,"TYPE")="INTERACTIVE"
  ;
  ;Install selected component
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;10/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMEXLM ; SLC/PKR/PJH - Clinical Reminder Exchange List Manager routines. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================
@@ -41,6 +41,23 @@
  ;
  ;=====================================================
+EN ;Main entry point for PXRM EXCHANGE
+ N PXRMDONE,PXRMNMCH
+ ;PXRMDONE is set to true if the user enters an action of Quit.
+ S PXRMDONE=0
+ ;PXRMNMCH is used to store name change information. If a finding
+ ;is copied to a new name or is replaced by another finding the
+ ;information is stored here. It is used when installing definitions
+ ;or dialogs so they use the new or replaced finding.
+ N VALMBCK,VALMSG,X,XMZ
+ S X="IORESET"
+ D ENDR^%ZISS
+ D BLDLIST^PXRMEXLC(0)
+ D EN^VALM("PXRM EX REMINDER EXCHANGE")
+ W IORESET
+ D KILL^%ZISS
+ Q
+ ;
+ ;=====================================================
 ENTRY ;Entry code
- D BLDLIST^PXRMEXLC(0)
  D XQORM
  Q
@@ -52,5 +69,4 @@
  K ^TMP("PXRMEXFND",$J)
  K ^TMP("PXRMEXIA",$J)
- K ^TMP("PXRMEXIAD",$J)
  K ^TMP("PXRMEXID",$J)
  K ^TMP("PXRMEXIH",$J)
@@ -166,27 +182,8 @@
  Q
  ;
- ;=====================================================
-START ;Main entry point for PXRM EXCHANGE
- N PXRMDONE,PXRMNMCH
- ;PXRMDONE is set to true if the user enters an action of Quit.
- S PXRMDONE=0
- ;PXRMNMCH is used to store name change information. If a finding
- ;is copied to a new name or is replaced by another finding the
- ;information is stored here. It is used when installing definitions
- ;or dialogs so they use the new or replaced finding.
- N VALMBCK,VALMSG,X,XMZ
- S X="IORESET"
- D ENDR^%ZISS
- D EN^VALM("PXRM EX REMINDER EXCHANGE")
- W IORESET
- D KILL^%ZISS
- Q
- ;
- ;=====================================================
 XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT ENTRY",0))_U_"1:"_VALMCNT
  S XQORM("A")="Select Action: "
  Q
  ;
- ;=====================================================
 XSEL ;PXRM EXCH SELECT COMPONENT validation
  N SEL,PXRMRIEN
@@ -198,10 +195,10 @@
  .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 repository ien.
- S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",SEL)
+ S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",SEL,SEL)
  ;
  ;Full screen mode
@@ -233,10 +230,19 @@
  .;Rebuild the list for List Manager to display.
  .K ^TMP("PXRMEXLR",$J)
- .D REXL^PXRMLIST("PXRMEXLR")
- .S VALMCNT=^TMP("PXRMEXLR",$J,"VALMCNT")
+ .D RE^PXRMLIST(.RELIST,.IEN)
+ .M ^TMP("PXRMEXLR",$J)=RELIST
+ .S VALMCNT=RELIST("VALMCNT")
+ .F IND=1:1:VALMCNT D
+ ..S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
+ .;
  .S VALMHDR(1)="Deleted 1 exchange file entry",VALMHDR(2)=" ",VALMBCK="R"
  ;
- I OPTION="IH" D START^PXRMEXIH
- ;
- S VALMBCK="R"
- Q
+ I OPTION="IH" D
+ .N HISLIST,VALMCNT
+ .S HISLIST(SEL)=""
+ .D HISTLIST^PXRMEXLC(.HISLIST,.VALMCNT)
+ .D EN^VALM("PXRM EX INSTALLATION HISTORY")
+ .K ^TMP("PXRMEXIH",$J)
+ ;
+ S VALMBCK="R"
+ Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXLR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXLR ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;07/30/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXLR ; SLC/PKR/PJH - List Manager routines for existing repository entries. ;01/10/2003
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==================================================
 CHF ;Create a host file containing repository entries.
@@ -50,5 +50,8 @@
  ;Rebuild the list for List Manager to display.
  K ^TMP("PXRMEXLR",$J)
- D REXL^PXRMLIST("PXRMEXLR")
+ D RE^PXRMLIST(.RELIST,.IEN)
+ M ^TMP("PXRMEXLR",$J)=RELIST
+ S VALMCNT=RELIST("VALMCNT")
+ F IND=1:1:VALMCNT S ^TMP("PXRMEXLR",$J,"IDX",IND,IND)=IEN(IND)
  ;
  S VALMHDR(1)="Deleted "_DELLIST("COUNT")_" Exchange File"
@@ -61,4 +64,28 @@
  ;
  ;==================================================
+DELHIST ;Get a list of repository installation entries and delete them.
+ ;Save the original list, it contains the selected repository entries.
+ N VALMYO
+ M VALMYO=VALMY
+ N IHIND,IND,RIEN,TEMP,VALMY
+ N VALMBG,VALMLST
+ ;
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXIH",$J,"IDX",""),-1)
+ ;Get the list to delete.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ S IND=""
+ F  S IND=$O(VALMY(IND)) Q:IND=""  D
+ . S TEMP=^TMP("PXRMEXIH",$J,"SEL",IND)
+ . S RIEN=$P(TEMP,U,1)
+ . S IHIND=$P(TEMP,U,2)
+ . D DELHIST^PXRMEXU1(RIEN,IHIND)
+ ;Rebuild the display list.
+ D HISTLIST^PXRMEXLC(.VALMYO,.VALMCNT)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
 EXIT ; Exit code
  D CLEAN^VALM10
@@ -69,4 +96,85 @@
  ;
  ;==================================================
+IH ;Get a list of repository entries and show their installation history.
+ N VALMCNT,VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ ;Build a history list.
+ D HISTLIST^PXRMEXLC(.VALMY,.VALMCNT)
+ D EN^VALM("PXRM EX INSTALLATION HISTORY")
+ K ^TMP("PXRMEXIH",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
+INDETAIL ;Output the details of an installation.
+ N VALMBG,VALMCNT,VALMHDR,VALMLST,VALMY
+ S VALMBG=1,VALMLST=+$O(^TMP("PXRMEXIH",$J,"IDX",""),-1)
+ ;Get the list to display.
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ D INDISP(.VALMY)
+ Q
+ ;
+ ;==================================================
+INDISP(ARRAY) ;Display details list
+ N ACTION,CMPNT,DI,DP,ENTRY,IHIND,IND,INDEX,JND,KND
+ N NAME,NEWNAME,NLINE,RIEN,TEMP
+ K ^TMP("PXRMEXID",$J)
+ ;If there are no items then quit.
+ I '$D(ARRAY) Q
+ S (IND,NLINE)=0
+ F  S IND=$O(ARRAY(IND)) Q:IND=""  D
+ . S TEMP=^TMP("PXRMEXIH",$J,"SEL",IND)
+ . S RIEN=$P(TEMP,U,1)
+ . S IHIND=$P(TEMP,U,2)
+ . S TEMP=^PXD(811.8,RIEN,0)
+ . S ENTRY=$E($P(TEMP,U,1),1,38)
+ . S ENTRY=$$LJ^XLFSTR(ENTRY,38," ")
+ . S DP=$$FMTE^XLFDT($P(TEMP,U,3),"5Z")
+ . S DI=$$FMTE^XLFDT(^PXD(811.8,RIEN,130,IHIND,0),"5Z")
+ . I NLINE>1 D
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXID",$J,NLINE,0)="------------------------------------------------------------------------------"
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)=ENTRY_" "_DP_"  "_DI
+ .;Write the header line here.
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)="     Component                         Action  New Name"
+ . S CMPNT=""
+ . S JND=0
+ . F  S JND=$O(^PXD(811.8,RIEN,130,IHIND,1,JND)) Q:JND=""  D
+ .. S TEMP=^PXD(811.8,RIEN,130,IHIND,1,JND,0)
+ .. I $P(TEMP,U,2)'=CMPNT D
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=" "
+ ... S CMPNT=$P(TEMP,U,2)
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=CMPNT
+ .. S INDEX=$$RJ^XLFSTR($P(TEMP,U,1),4," ")
+ .. S NAME=$E($P(TEMP,U,3),1,36)
+ .. S NAME=$$LJ^XLFSTR(NAME,36," ")
+ .. S ACTION=$P(TEMP,U,4)
+ .. S NEWNAME=$E($P(TEMP,U,5),1,36)
+ .. S NEWNAME=$$LJ^XLFSTR(NEWNAME,36," ")
+ .. S NLINE=NLINE+1
+ .. S ^TMP("PXRMEXID",$J,NLINE,0)=INDEX_" "_NAME_" "_ACTION_"    "_NEWNAME
+ ..;If there are Additional Details add them to the display.
+ .. S KND=0
+ .. F  S KND=$O(^PXD(811.8,RIEN,130,IHIND,1,JND,1,KND)) Q:KND=""  D
+ ... S NLINE=NLINE+1
+ ... S ^TMP("PXRMEXID",$J,NLINE,0)=^PXD(811.8,RIEN,130,IHIND,1,JND,1,KND,0)
+ . S NLINE=NLINE+1
+ . S ^TMP("PXRMEXID",$J,NLINE,0)=" "
+ S VALMHDR(1)=^PXD(811.8,RIEN,0)_"  "_^TMP("PXRMEXID",$J,1,0)
+ S VALMCNT=NLINE
+ D EN^VALM("PXRM EX INSTALLATION DETAIL")
+ K ^TMP("PXRMEXID",$J)
+ S VALMBCK="R"
+ Q
+ ;
+ ;==================================================
 INSTALL ;Get a list of repository entries and install them.
  N IND,PXRMRIEN,VALMY
@@ -79,5 +187,5 @@
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the repository ien.
- . S PXRMRIEN=^TMP("PXRMEXLR",$J,"SEL",IND)
+ . S PXRMRIEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
  .;The list template calls INSTALL^PXRMEXLI
  . D EN^VALM("PXRM EX LIST COMPONENTS")
@@ -98,4 +206,12 @@
  ;
  ;==================================================
+IS ;Get a list of packed reminders and print the installation summary.
+ N VALMY
+ D EN^VALM2(XQORNOD(0))
+ ;If there is no list quit.
+ I '$D(VALMY) Q
+ Q
+ ;
+ ;==================================================
 MIENLIST(LIST) ;Get a list of List Manager repository entries and turn it
  ;into iens.
@@ -108,6 +224,5 @@
  F  S IND=$O(VALMY(IND)) Q:+IND=0  D
  . S COUNT=COUNT+1
- . ;S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
- . S IEN=^TMP("PXRMEXLR",$J,"SEL",IND)
+ . S IEN=^TMP("PXRMEXLR",$J,"IDX",IND,IND)
  . S LIST(IEN)=""
  S LIST("COUNT")=COUNT
@@ -117,4 +232,23 @@
 PEXIT ;PXRM EXCH INSTALLATION MENU protocol exit code
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- Q
- ;
+ ;Reset after page up/down etc
+ D XQORM
+ Q
+ ;
+ ;==================================================
+XQORM S XQORM("#")=$O(^ORD(101,"B","PXRM EXCH SELECT HISTORY",0))_U_"1:"_VALMCNT
+ S XQORM("A")="Select Action: "
+ Q
+ ;
+ ;==================================================
+XSEL ;PXRM EXCH SELECT HISTORY validation
+ N ARRAY,CNT,SELECT,SEL
+ S SELECT=$P(XQORNOD(0),"=",2)
+ I '$$VALID^PXRMEXLD(SELECT) S VALMBCK="R" Q
+ ;Build array of selected items
+ F CNT=1:1 S SEL=$P(SELECT,",",CNT) Q:'SEL  D
+ .S ARRAY(SEL)=""
+ ;
+ ;Display Selected Histories
+ D INDISP(.ARRAY)
+ Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXPR ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;12/12/2006
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXPR ; SLC/PKR/PJH - Routines to create packed reminder definitions. ;02/25/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;===============================================================
 ADDFILE(FLIST,ROOT,FILENAME) ;Add a file to the list of finding files.
@@ -29,6 +29,6 @@
  D GETSPON(811.9,RIEN,.SPONLIST)
  ;If there is a dialog add it.
- ;S DIEN=+$P($G(^PXD(811.9,RIEN,51)),U,1)
- ;I DIEN>0 D GETSPON(801.41,DIEN,.SPONLIST)
+ S DIEN=+$P($G(^PXD(811.9,RIEN,51)),U,1)
+ I DIEN>0 D GETSPON(801.41,DIEN,.SPONLIST)
  ;Go through the finding list to find additional sponsors.
  S IND=""
@@ -122,5 +122,5 @@
  ;Save the source information
  I +RTP'>0 Q
- K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
+ K ^TMP(TMPIND,$J)
  D PUTSRC(RTP,TMPIND)
  ;
@@ -152,5 +152,5 @@
  ;If a dialog exists for this reminder add it and its findings to the
  ;list. Also collect any embedded TIU objects or templates
- D DIALOG^PXRMEXDG(RIEN,.DLGLIST,.FINDLIST,.OBJLIST,.TEMLIST,.SPONLIST)
+ D DIALOG^PXRMEXDG(RIEN,.DLGLIST,.FINDLIST,.OBJLIST,.TEMLIST)
  ;
  ;If there were education topics make sure subtopics are included.
@@ -226,4 +226,5 @@
  S LOC=$$SITE^VASITE
  S ^TMP(TMPIND,$J,"SRC","REMINDER")=$P(RTP,U,2)
+ ;S ^TMP(TMPIND,$J,"SRC","USER")=$P(^VA(200,DUZ,0),U,1)
  S ^TMP(TMPIND,$J,"SRC","USER")=$$GET1^DIQ(200,DUZ,.01)
  S ^TMP(TMPIND,$J,"SRC","SITE")=$P(LOC,U,2)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXPU.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;09/10/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXPU ; SLC/PKR - Utilities for packing and unpacking repository entries. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;==================================================
 BTTABLE(DIQOUT,IENROOT,TTABLE) ;Build the DIQOUT to FDA iens translation table.
@@ -13,5 +13,5 @@
  . S TTABLE(FILENUM,IENS)="+"_IENS
  E  D  Q
- . W !,"BTTABLE^PXRMEXPU - DIQOUT problem, do not have correct top level"
+ . W !,"BTTABLE^PXRMEXPU - DIQOUT problem do not have correct top level"
  ;
  F  S FILENUM=$O(DIQOUT(FILENUM)) Q:FILENUM=""  D
@@ -43,6 +43,4 @@
  ... I '$D(TYPE(FILENUM,FIELD)) S TYPE(FILENUM,FIELD)=$$GET1^DID(FILENUM,FIELD,"","TYPE")
  ... S PTRTO=$S(TYPE(FILENUM,FIELD)="POINTER":$$GET1^DID(FILENUM,FIELD,"","POINTER"),1:"")
- ... ;Remove pointers to file 200.
- ... I PTRTO="VA(200," S DIQOUT(FILENUM,IENS,FIELD)="" Q
  ...;If the field's type is COMPUTED then don't transport it.
  ... I TYPE(FILENUM,FIELD)="COMPUTED" K DIQOUT(FILENUM,IENS,FIELD) Q
@@ -91,5 +89,5 @@
  ;==================================================
 GDIQF(LIST,NUM,TMPIND,SERROR) ;Save file entries into ^TMP(TMPIND,$J).
- N CSUM,DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
+ N DIQOUT,IENROOT,IND,FIELD,FILENAME,IENS,MSG,PT01,TEMP
  S ^TMP(TMPIND,$J,"NUMF")=NUM
  F IND=1:1:NUM D
@@ -103,5 +101,5 @@
  . I $$FOKTI^PXRMEXFI(FILENUM) S FIELD="**"
  . E  S FIELD=.01
- . D GETS^DIQ(FILENUM,IEN,FIELD,"N","DIQOUT","MSG")
+ . D GETS^DIQ(FILENUM,IEN,FIELD,"","DIQOUT","MSG")
  . I $D(MSG) D  Q
  .. S SERROR=1,IND=NUM
@@ -117,6 +115,4 @@
  .;Convert the iens to the FDA adding form.
  . D CONTOFDA(.DIQOUT,.IENROOT)
- . S CSUM=$$DIQOUTCS^PXRMEXCS(.DIQOUT)
- . S ^TMP("PXRMEXCS",$J,IND,FILENAME)=CSUM
  .;Load the converted DIQOUT into TMP.
  . M ^TMP(TMPIND,$J,IND,FILENAME)=DIQOUT
@@ -135,5 +131,5 @@
  ;==================================================
 GRTN(LIST,NUM,TMPIND,SERROR) ;Save routines into ^TMP(TMPIND,$J).
- N DIF,IEN,IND,RA,TEMP,X,XCNP
+ N DIF,IEN,IND,TEMP,X,XCNP
  S ^TMP(TMPIND,$J,"NUMR")=NUM
  S X=""
@@ -143,10 +139,7 @@
  . X ^%ZOSF("TEST")
  . I $T D
- .. K RA
- .. S DIF="RA("
+ .. S DIF="^TMP(TMPIND,$J,""ROUTINE"","""_X_""","
  .. S XCNP=0
  .. X ^%ZOSF("LOAD")
- .. S ^TMP("PXRMEXCS",$J,"ROUTINE",X)=$$ROUTINE^PXRMEXCS(.RA)
- .. M ^TMP(TMPIND,$J,"ROUTINE",X)=RA
  . E  D
  .. S SERROR=1
@@ -156,8 +149,8 @@
  ;
  ;==================================================
-RMEH(FILENUM,DIQOUT,NOSTUB) ;Clear the edit history from all reminder files.
+RMEH(FILENUM,DIQOUT) ;Clear the edit history from all reminder files.
  ;Leave a stub so it can be filled in when the file is installed.
  I (FILENUM<800)!(FILENUM>811.9) Q
- N IENS,SFN,TARGET
+ N IEN,SFN,TARGET
  ;Edit History is stored in node 110 for all files, get the
  ;subfile number.
@@ -169,5 +162,4 @@
  F  S IENS=$O(DIQOUT(SFN,IENS)) Q:IENS=""  K DIQOUT(SFN,IENS)
  ;Create a stub for the install.
- I $G(NOSTUB) Q
  S IENS="1,"_$O(DIQOUT(FILENUM,""))
  S DIQOUT(SFN,IENS,.01)=$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXSI.m	(revision 636)
@@ -1,10 +1,62 @@
-PXRMEXSI ; SLC/PKR/PJH - Silent repository entry install. ;09/28/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXSI ; SLC/PKR/PJH - Silent repository entry install. ;12/22/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
+ ;
+ ;===================================================
+BUILD ;Build list manager workfile from ^TMP("PXRMEXTMP" (see ^PXRMEXLB)
+ N DDATA,DDLG,IND,JND,NLINE,NSEL
+ S NLINE=0,NSEL=0
+ S DDLG=$G(^TMP("PXRMEXTMP",$J,"PXRMDNAM")) Q:DDLG=""
+ ;
+ ;Save reminder dialog
+ S DDATA=^TMP("PXRMEXTMP",$J,"DLOC",DDLG)
+ S IND=$P(DDATA,U,3),JND=$P(DDATA,U,4)
+ D DSAVE(DDLG,IND,JND)
+ ;
+ ;Process sub-components
+ I $D(^TMP("PXRMEXTMP",$J,"DREPL",DDLG))>0 D DREPL(DDLG)
+ D DCMP(DDLG)
+ Q
+ ;
+ ;===================================================
+DCMP(DLG) ;Search for dialog components
+ N DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND
+ S DSEQ=0
+ F  S DSEQ=$O(^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)) Q:'DSEQ  D
+ . S DDATA=^TMP("PXRMEXTMP",$J,"DMAP",DLG,DSEQ)
+ . S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ . S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ .;Save line in workfile
+ . D DSAVE(DNAM,IND,JND)
+ .;
+ . I $D(^TMP("PXRMEXTMP",$J,"DREPL",DNAM))>0 D DREPL(DNAM)
+ .;Process any sub-components
+ . I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM)
+ Q
+ ;
+ ;===================================================
+DREPL(DLG,LEV) ;
+ N DDATA,DDLG,DEND,DNAM,DSEQ,DSTRT,IND,JND
+ S DDATA=^TMP("PXRMEXTMP",$J,"DREPL",DLG)
+ S DNAM=$P(DDATA,U),DSTRT=$P(DDATA,U,2),DEND=$P(DDATA,U,3) Q:DNAM=""
+ S IND=$P(DDATA,U,4),JND=$P(DDATA,U,5)
+ ;Save line in workfile
+ D DSAVE(DNAM,IND,JND)
+ I $D(^TMP("PXRMEXTMP",$J,"DMAP",DNAM)) D DCMP(DNAM)
+ Q
+ ;===================================================
+DSAVE(DNAM,IND,JND) ;Update workfile
+ ;Ignore national prompts
+ I $$PXRM^PXRMEXID(DNAM) Q
+ N DEXIST
+ S NSEL=NSEL+1
+ ;Check if dialog exists
+ S DEXIST=$$EXISTS^PXRMEXIU(801.41,DNAM)
+ ;Store the file number, start and stop line in the exchange file.
+ S ^TMP("PXRMEXLD",$J,"SEL",NSEL)=FILENUM_U_IND_U_JND_U_DEXIST
+ Q
  ;
  ;===================================================
 INITMPG ;Initialize ^TMP arrays.
- K ^TMP("PXRMEXFND",$J)
  K ^TMP("PXRMEXIA",$J)
- K ^TMP("PXRMEXIAD",$J)
  K ^TMP("PXRMEXLC",$J)
  K ^TMP("PXRMEXLD",$J)
@@ -13,72 +65,55 @@
  ;
  ;===================================================
-INSCOM(PXRMRIEN,ACTION,IND,TEMP,REMNAME,HISTSUB) ;Install component IND
- ;of PXRMRIEN.
- N ATTR,END,EXISTS,FILENUM,IND120,JND120,NAME
- N PT01,RTN,SAME,START,TEXT
+INSCOM(PXRMRIEN,IND,TEMP,REMNAME) ;Install component IND of PXRMRIEN.
+ N ACTION,ATTR,END,EXISTS,FILENUM,IND120,JND120,NAME
+ N PT01,RTN,START
  S FILENUM=$P(TEMP,U,1),EXISTS=$P(TEMP,U,4)
  S IND120=$P(TEMP,U,2),JND120=$P(TEMP,U,3)
- I (IND120="")!(JND120="") Q
  S TEMP=^PXD(811.8,PXRMRIEN,120,IND120,1,JND120,0)
- ;If the component does not exist then the action has to be "I".
- ;If the component exists and the action is "I" change it to "O".
- ;If the component exists and the action is "M" leave it "M".
- ;If the component exists and the action is "O" leave it "O".
- S ACTION=$S('EXISTS:"I",ACTION="I":"O",1:ACTION)
- S SAME=0
+ I (FILENUM=801.41)!(FILENUM=811.5) S ACTION=$S(EXISTS:"M",1:"I")
+ E  S ACTION=$S(EXISTS:"O",1:"I")
  S START=$P(TEMP,U,2)
  S END=$P(TEMP,U,3)
+ S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
  I FILENUM=0 D
  . D RTNLD^PXRMEXIC(PXRMRIEN,START,END,.ATTR,.RTN)
- . I EXISTS D
- .. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
- .. S CSUM=$$RTNCS^PXRMEXCS(ATTR("NAME"))
- .. I ATTR("CHECKSUM")=CSUM S SAME=1,ACTION="S"
+ .;Save what was done for the installation summary.
  . S ^TMP("PXRMEXIA",$J,IND,"ROUTINE",ATTR("NAME"),ACTION)=""
  E  D 
- . S TEMP=^PXD(811.8,PXRMRIEN,100,START,0)
  . S PT01=$P(TEMP,"~",2)
- .;Save reminder name for dialog install.
- . I FILENUM=811.9 S REMNAME=PT01
- . D SETATTR^PXRMEXFI(.ATTR,FILENUM,PT01)
- . I EXISTS D
- .. D CHECKSUM^PXRMEXCS(.ATTR,START,END)
- .. S CSUM=$$FILE^PXRMEXCS(ATTR("FILE NUMBER"),EXISTS)
- .. I ATTR("CHECKSUM")=CSUM S SAME=1,ACTION="S"
+ . S (ATTR("NAME"),ATTR("PT01"))=PT01
+ . D SETATTR^PXRMEXFI(.ATTR,FILENUM)
  .;Save what was done for the installation summary.
- . S ^TMP(HISTSUB,$J,IND,ATTR("FILE NAME"),PT01,ACTION)=""
- ;If the packed component and the installed component are the same
- ;there is nothing to do.
- I SAME Q
+ . S ^TMP("PXRMEXIA",$J,IND,ATTR("FILE NAME"),PT01,ACTION)=""
  ;Install this component.
  I FILENUM=0 D RTNSAVE^PXRMEXIC(.RTN,ATTR("NAME"))
  E  D FILE^PXRMEXIC(PXRMRIEN,EXISTS,IND120,JND120,ACTION,.ATTR,.PXRMNMCH)
+ ;Save reminder name
+ I FILENUM=811.9 S REMNAME=PT01
+ ;If this component was not installed add to the no install message.
  Q
  ;
  ;===================================================
-INSDLG(PXRMRIEN,ACTION) ;Install dialog components directly
- ;from the "SEL" array.
- N IND,FILENUM,ITEMP,NAME,REMNAME,TEMP
- ;Build the selection array in ^TMP("PXRMEXLD",$J,"SEL"). For dialogs
- ;the selection array is: 
- ;file no.^FDA start^FDA end^EXISTS^IND120^JND120^NAME
- D BLDDISP^PXRMEXD1(0)
- ;Work through the selection array installing the dialog parts
- ;in reverse order.
- S IND=""
- F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:(IND="")!(PXRMDONE)  D
- . S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND)
- . S FILENUM=$P(TEMP,U,1),NAME=$P(TEMP,U,7)
- .;Dialog elements may be used more than once in a dialog so make sure
- .;the element has not already been installed.
- . S ITEMP=$P(TEMP,U,1)_U_$P(TEMP,U,5,6)_U_$$EXISTS^PXRMEXIU(FILENUM,NAME)
- . D INSCOM(PXRMRIEN,ACTION,IND,ITEMP,.REMNAME,"PXRMEXIAD")
+INSDLG(PXRMRIEN) ;Install dialog components (in reverse order)
+ ;
+ K ^TMP("PXRMEXSI",$J)
+ N IND,TEMP,JND120,KIDSDONE
+ ;Build list of components
+ D BUILD
+ S IND="",KIDSDONE=0
+ F  S IND=$O(^TMP("PXRMEXLD",$J,"SEL",IND),-1) Q:'IND!(KIDSDONE=1)  D
+ . S TEMP=^TMP("PXRMEXLD",$J,"SEL",IND),JND120=$P(TEMP,U,3)
+ .;Skip install if dialog occurs more than once
+ . I $D(^TMP("PXRMEXSI",$J,JND120)) Q
+ . S ^TMP("PXRMEXSI",$J,JND120)=""
+ .;Silent Dialog Install
+ . D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME)
+ K ^TMP("PXRMEXSI",$J)
  Q
  ;
  ;===================================================
-INSTALL(PXRMRIEN,ACTION,NOR) ;Install all components in a repository entry.
+INSTALL(PXRMRIEN,NOR) ;Install all components in a repository entry.
  ;If NOR is true do not install routines.
- N DNAME,FILENUM,IND,PXRMDONE,PXRMNMCH,REMNAME,TEMP
- S PXRMDONE=0
+ N DNAME,FILENUM,IND,PXRMNMCH,REMNAME,TEMP
  S NOR=$G(NOR)
  ;Initialize ^TMP globals.
@@ -91,11 +126,10 @@
  ;Build the selectable list.
  D CDISP^PXRMEXLC(PXRMRIEN)
- ;Set the install date and time and type.
+ ;Set the install date and time.
  S ^TMP("PXRMEXIA",$J,"DT")=$$NOW^XLFDT
- S ^TMP("PXRMEXIA",$J,"TYPE")="SILENT"
  ;Initialize the name change storage.
  K PXRMNMCH
  S IND=0
- F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:(IND="")!(PXRMDONE)  D
+ F  S IND=$O(^TMP("PXRMEXLC",$J,"SEL",IND)) Q:+IND=0  D
  . S TEMP=^TMP("PXRMEXLC",$J,"SEL",IND)
  . S FILENUM=$P(TEMP,U,1)
@@ -103,7 +137,7 @@
  . I FILENUM=0,NOR Q
  . ;Install dialog components
- . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN,ACTION) Q
+ . I FILENUM=801.41 N PXRMDONE S PXRMDONE=0 D INSDLG(PXRMRIEN) Q
  . ;Install component
- . E  D INSCOM(PXRMRIEN,ACTION,IND,TEMP,.REMNAME,"PXRMEXIA")
+ . E  D INSCOM(PXRMRIEN,IND,TEMP,.REMNAME)
  ;
  ;Get the dialog name
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1.;08/16/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXU1 ; SLC/PKR/PJH - Reminder exchange repository utilities, #1. ;09/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;=====================================================
 CLIST(IEN) ;Build the list of components for the repository
@@ -98,9 +98,9 @@
  ;
  ;=====================================================
-DELHIST(RIEN,IHIEN) ;Delete install history IHIEN in repository entry RIEN.
- N DA,DIK
- S DA=IHIEN,DA(1)=RIEN
- S DIK="^PXD(811.8,"_DA(1)_",130,"
- D ^DIK
+DELHIST(RIEN,IHIND) ;Delete install history IHIND in repository entry RIEN.
+ N DATE
+ S DATE=$P(^PXD(811.8,RIEN,130,IHIND,0),U)
+ K ^PXD(811.8,RIEN,130,IHIND)
+ K ^PXD(811.8,RIEN,130,"B",DATE)
  Q
  ;
@@ -146,82 +146,72 @@
 RIEN(LIEN) ;Given the list ien return the repository ien.
  N RIEN
- S RIEN=$G(^TMP("PXRMEXLR",$J,"SEL",LIEN))
+ S RIEN=$G(^TMP("PXRMEXLR",$J,"IDX",LIEN,LIEN))
  Q RIEN
  ;
  ;=====================================================
 SAVHIST ;Save the installation history in the repository.
- N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,NEWNAME
- N SUB,TEMP,TOTAL,TYPE,USER
+ N ACTION,DATE,CMPNT,FTYPE,IND,INDEX,ITEM,JND,NEWNAME,TEMP,USER
  ;Find the first open spot in the Installation History node.
  S (IND,JND)=0
- F  S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(IND>JND)
+ F  S IND=+$O(^PXD(811.8,PXRMRIEN,130,IND)) S JND=JND+1 Q:(IND=0)!(JND>IND)
+ ;Set the 0 node.
+ S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_JND_U_JND
  S IND=JND
- S JND=0
- F SUB="PXRMEXIA","PXRMEXIAD" D
- . S INDEX=0
- . F  S INDEX=$O(^TMP(SUB,$J,INDEX)) Q:+INDEX=0  D
- .. S JND=JND+1
- .. S CMPNT=$O(^TMP(SUB,$J,INDEX,""))
- .. S ITEM=$O(^TMP(SUB,$J,INDEX,CMPNT,""))
- .. S ACTION=$O(^TMP(SUB,$J,INDEX,CMPNT,ITEM,""))
- .. S NEWNAME=$G(^TMP(SUB,$J,INDEX,CMPNT,ITEM,ACTION))
- .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
- ..;Set the 0 node.
- .. S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
- ..;Check for finding item changes and save them.
- .. S FTYPE=""
- .. I CMPNT["DEFINITION" S FTYPE="DEFF"
- .. I CMPNT["DIALOG" S FTYPE="DIAF"
- .. I CMPNT["TERM" S FTYPE="TRMF"
- .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
- ... N FI,FINDING,KND,OFINDING
- ... S KND=2
- ... S FI=""
- ... F  S FI=$O(^TMP(SUB,$J,FTYPE,FI)) Q:FI=""  D
- .... S OFINDING=$O(^TMP(SUB,$J,FTYPE,FI,""))
- .... S FINDING=^TMP(SUB,$J,FTYPE,FI,OFINDING)
- .... I OFINDING=FINDING Q
+ S DATE=^TMP("PXRMEXIA",$J,"DT")
+ S USER=$$GET1^DIQ(200,DUZ,.01,"")
+ S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER
+ S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
+ S (INDEX,JND)=0
+ F  S INDEX=$O(^TMP("PXRMEXIA",$J,INDEX)) Q:+INDEX=0  D
+ . S JND=JND+1
+ . S CMPNT=$O(^TMP("PXRMEXIA",$J,INDEX,""))
+ . S ITEM=$O(^TMP("PXRMEXIA",$J,INDEX,CMPNT,""))
+ . S ACTION=$O(^TMP("PXRMEXIA",$J,INDEX,CMPNT,ITEM,""))
+ . S NEWNAME=$G(^TMP("PXRMEXIA",$J,INDEX,CMPNT,ITEM,ACTION))
+ . S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,0)=INDEX_U_CMPNT_U_ITEM_U_ACTION_U_NEWNAME
+ .;Set the 0 node.
+ . S ^PXD(811.8,PXRMRIEN,130,IND,1,0)=U_"811.8031A"_U_JND_U_JND
+ .;Check for finding item changes and save them.
+ . S FTYPE=""
+ . I CMPNT["DEFINITION" S FTYPE="DEFF"
+ . I CMPNT["DIALOG" S FTYPE="DIAF"
+ . I CMPNT["TERM" S FTYPE="TRMF"
+ . I (FTYPE'=""),($D(^TMP("PXRMEXIA",$J,FTYPE))) D
+ .. N FI,FINDING,KND,OFINDING
+ .. S KND=2
+ .. S FI=""
+ .. F  S FI=$O(^TMP("PXRMEXIA",$J,FTYPE,FI)) Q:FI=""  D
+ ... S OFINDING=$O(^TMP("PXRMEXIA",$J,FTYPE,FI,""))
+ ... S FINDING=^TMP("PXRMEXIA",$J,FTYPE,FI,OFINDING)
+ ... I OFINDING=FINDING Q
+ ... S KND=KND+1
+ ... S TEMP=$E(OFINDING,1,33)
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
+ .. S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
+ .. I KND>2 D
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   Finding Changes"
+ ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
+ .;
+ .;Check for TIU template replacements and save them.
+ . I CMPNT["DIALOG" S FTYPE="DIATIU"
+ . E  S FTYPE=""
+ . I (FTYPE'=""),($D(^TMP("PXRMEXIA",$J,FTYPE))) D
+ .. N KND,OTIUT,TIUT,TYPE
+ .. S TYPE=""
+ .. S KND=2
+ .. F  S TYPE=$O(^TMP("PXRMEXIA",$J,FTYPE,TYPE)) Q:TYPE=""  D
+ ... S OTIUT=""
+ ... F  S OTIUT=$O(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT)) Q:OTIUT=""  D
+ .... S TIUT=$G(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT))
+ .... I OTIUT=TIUT Q
+ .... I '$D(^TMP("PXRMEXIA",$J,FTYPE,TYPE,OTIUT,ITEM)) Q
  .... S KND=KND+1
- .... S TEMP=$E(OFINDING,1,33)
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_FINDING
+ .... S TEMP=$E(OTIUT,1,33)
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
  ... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
  ... I KND>2 D
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   Finding Changes"
+ .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   "_TYPE
  .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- ..;
- ..;Check for TIU template replacements and save them.
- .. I CMPNT["DIALOG" S FTYPE="DIATIU"
- .. E  S FTYPE=""
- .. I (FTYPE'=""),($D(^TMP(SUB,$J,FTYPE))) D
- ... N KND,OTIUT,TIUT,TYPE
- ... S TYPE=""
- ... S KND=2
- ... F  S TYPE=$O(^TMP(SUB,$J,FTYPE,TYPE)) Q:TYPE=""  D
- .... S OTIUT=""
- .... F  S OTIUT=$O(^TMP(SUB,$J,FTYPE,TYPE,OTIUT)) Q:OTIUT=""  D
- ..... S TIUT=$G(^TMP(SUB,$J,FTYPE,TYPE,OTIUT))
- ..... I OTIUT=TIUT Q
- ..... I '$D(^TMP(SUB,$J,FTYPE,TYPE,OTIUT,ITEM)) Q
- ..... S KND=KND+1
- ..... S TEMP=$E(OTIUT,1,33)
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,KND,0)="    "_TEMP_$$INSCHR^PXRMEXLC((35-$L(TEMP))," ")_TIUT
- .... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,0)=U_"811.80315A"_U_KND_U_KND
- .... I KND>2 D
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,1,0)="   "_TYPE
- ..... S ^PXD(811.8,PXRMRIEN,130,IND,1,JND,1,2,0)="     Original"_$$INSCHR^PXRMEXLC(27," ")_"New"
- ;If JND is still 0 then there was nothing to save.
- I JND>0 D
- .;Save the header information.
- . S DATE=^TMP("PXRMEXIA",$J,"DT")
- . S TYPE=^TMP("PXRMEXIA",$J,"TYPE")
- . S USER=$$GET1^DIQ(200,DUZ,.01,"")
- . S ^PXD(811.8,PXRMRIEN,130,IND,0)=DATE_U_USER_U_TYPE
- . S ^PXD(811.8,PXRMRIEN,130,"B",DATE,IND)=""
- .;Set the 0 node.
- . S (KND,TOTAL)=0
- . F  S KND=+$O(^PXD(811.8,PXRMRIEN,130,KND)) Q:KND=0  S TOTAL=TOTAL+1
- . S ^PXD(811.8,PXRMRIEN,130,0)=U_"811.803DA"_U_IND_U_TOTAL
  K ^TMP("PXRMEXIA",$J)
- K ^TMP("PXRMEXIAD",$J)
- Q
- ;
+ Q
+ ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU2.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;11/21/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXU2 ; SLC/PKR/PJH - Reminder exchange repository utilities, #2. ;09/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;=====================================================
 FDA(IND,LC,TMPIND,FILENAME) ;Build the XML FDA output.
@@ -59,5 +59,5 @@
  S ^TMP("PXRMEXRS",$J,1,0)="<?xml version=""1.0"" standalone=""yes""?>"
  S ^TMP("PXRMEXRS",$J,2,0)="<REMINDER_EXCHANGE_FILE_ENTRY>"
- S VERSN=$P(^PXRM(800,1,"VERSION"),U,1)
+ S VERSN=^PXRM(800,1,"VERSION")
  S ^TMP("PXRMEXRS",$J,3,0)="<PACKAGE_VERSION>"_VERSN_"</PACKAGE_VERSION>"
  ;The pointer to the index will be on line 4 so leave room.
@@ -101,5 +101,4 @@
  . S ^TMP($J,"CIND",NCMPNT,"M_ROUTINE_START")=LC
  . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<ROUTINE_NAME>"_RNAME_"</ROUTINE_NAME>"
- . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,"ROUTINE",RNAME)_"</CHECKSUM>"
  . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CODE>"
  . S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<![CDATA["
@@ -138,5 +137,4 @@
  ... S ^TMP("PXRMEXRS",$J,LC,0)="<POINT_01>"_$$TOXML^PXRMEXU3(PT01)_"</POINT_01>"
  ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<INTERNAL_ENTRY_NUMBER>"_+SIENS_"</INTERNAL_ENTRY_NUMBER>"
- ... S LC=LC+1,^TMP("PXRMEXRS",$J,LC,0)="<CHECKSUM>"_^TMP("PXRMEXCS",$J,IND,FILENAME)_"</CHECKSUM>"
  ... S ^TMP($J,"CIND",NCMPNT,"FDA_START")=LC+3
  ... D FDA(IND,.LC,TMPIND,FILENAME)
@@ -180,10 +178,11 @@
  . S DESL("SOURCE")=^TMP(TMPIND,$J,"SRC","USER")_" at "_^TMP(TMPIND,$J,"SRC","SITE")
  . S DESL("DATEP")=^TMP(TMPIND,$J,"SRC","DATE")
- . S DESL("VRSN")=VERSN
+ . S DESL("VRSN")=$G(^PXRM(800,1,"VERSION"))
  . S DESC="^TMP(TMPIND,$J,""DESC"")"
  . S KEYWORD="^TMP(TMPIND,$J,""KEYWORD"")"
  . D DESC^PXRMEXU1(IENROOT(1),.DESL,$NA(@DESC),$NA(@KEYWORD))
- K ^TMP($J,"CIND"),^TMP("PXRMEXRS",$J)
- K ^TMP(TMPIND,$J),^TMP("PXRMEXCS",$J)
+ K ^TMP($J,"CIND")
+ K ^TMP("PXRMEXRS",$J)
+ K ^TMP(TMPIND,$J)
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMEXU4.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;05/16/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMEXU4 ; SLC/PJH,PKR - Reminder Exchange #4, dialog changes. ;01/19/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;===============================================
 DLG(FDA,NAMECHG) ;Check the dialog for renamed entries, called by
@@ -15,6 +15,5 @@
  D BLDALIST^PXRMVPTR(801.4118,.01,.ALIST)
  ;Plus field 15 files
- ;S ALIST("MH")=601,ALIST("TX")=811.2
- S ALIST("MH")=601.71,ALIST("TX")=811.2
+ S ALIST("MH")=601,ALIST("TX")=811.2
  S ALIST("WH")=790.404
  ;Plus field 17 file
@@ -186,34 +185,4 @@
  .. I Y="" S ACTION="Q" Q
  .. I Y'="" S FDA(801.412,IENS,2)=$P(Y,U,2)
- ;Process Result Groups
- F  S IENS=$O(FDA(801.41121,IENS)) Q:IENS=""  D  I ACTION="Q" K FDA S (PXRMDONE,KIDSDONE)=1 Q
- . S PT01=$G(FDA(801.41121,IENS,.01)) Q:PT01=""
- . S FILENUM=801.41,NEWNAM=$G(NAMECHG(FILENUM,PT01))
- .I NEWNAM'="" D
- .. S FDA(801.41121,IENS,2)=NEWNAM,PT01=NEWNAM
- .S IEN=$$EXISTS^PXRMEXIU(FILENUM,PT01)
- .I IEN=0 D
- ..;Get replacement
- .. N DIC,DIR,DUOUT,MSG,X,Y
- .. S MSG(1)=" "
- .. S MSG(2)="RESULT GROUP entry "_PT01_" does not exist."
- .. D MES^XPDUTL(.MSG)
- .. S ACTION=$$GETACT^PXRMEXIU("DPQ",.DIR)
- .. I ACTION="S" S ACTION="Q"
- .. I ACTION="Q" Q
- .. I ACTION="D" K FDA(801.41121,IENS) Q
- .. S DIC=FILENUM
- .. S DIC(0)="AEMNQ"
- .. S DIC("S")="I ""S""[$P(^PXRMD(801.41,Y,0),U,4)"
- .. S Y=-1
- .. F  Q:+Y'=-1  D
- ...;If this is being called during a KIDS install we need echoing on.
- ... I $D(XPDNM) X ^%ZOSF("EON")
- ... D ^DIC
- ... I $D(XPDNM) X ^%ZOSF("EOFF")
- ... I $D(DUOUT) S Y="" Q
- ... I Y=-1 D BMES^XPDUTL("You must input a replacement!")
- .. I Y="" S ACTION="Q" Q
- .. I Y'="" S FDA(801.41121,IENS,.01)=$P(Y,U,2)
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFF.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;3/29/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFF ;SLC/PKR - Clinical Reminders function finding evaluation. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;===========================================
 EVAL(DFN,DEFARR,FIEVAL) ;Evaluate function findings.
@@ -70,5 +70,5 @@
  . S LNAME(IND)="PXRMFF"_IND
  . K ^TMP($J,LNAME(IND))
- . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,LNAME(IND))
+ . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,LNAME(IND))
  .;Get rid of the false part of the list.
  . K ^TMP($J,LNAME(IND),0)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFF0.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;09/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFF0 ;SLC/PKR - Clinical Reminders function finding routines. ;06/23/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;============================================
@@ -82,24 +82,4 @@
  ;
  ;============================================
-NUMERIC(LIST,FIEVAL,VALUE) ;Given a finding, return the first numeric
- ;portion of one of the "CSUB" values. Based on original work
- ;by R. Silverman.
- S VALUE=$G(FIEVAL(LIST(1),LIST(2),LIST(3)))
- S VALUE=$$FIRSTNUM(VALUE)
- Q
- ;
-FIRSTNUM(STRING) ;return the first numeric portion of a string.
- N CHAR,DONE,IND,NUMBER,NUMERIC
- S NUMERIC="+-.1234567890"
- S STRING=$TR(STRING," ")
- S DONE=0,IND=0,NUMBER=""
- F  Q:DONE  D
- . S IND=IND+1,CHAR=$E(STRING,IND)
- . I CHAR="" S DONE=1 Q
- . I NUMERIC[CHAR S NUMBER=NUMBER_CHAR
- . I NUMBER'="",NUMERIC'[CHAR S DONE=1
- Q +NUMBER
- ;
- ;============================================
 VALUE(LIST,FIEVAL,VALUE) ;Given a finding return one of its "CSUB"
  ;values.
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFAT.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;09/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFFAT ;SLC/PKR - Function Finding argument type routines. ;08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;============================================
@@ -48,8 +48,4 @@
  ;
  ;============================================
-NUMERIC(AN) ;
- Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")
- ;
- ;============================================
 VALUE(AN) ;
  Q $S(AN=1:"F",AN=2:"N",AN=3:"S",1:"U")
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMFFDB.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;10/31/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMFFDB ;SLC/PKR - Function finding data structure builder. ;06/22/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;===========================================
@@ -68,5 +68,5 @@
  N PFSTACK,REPL,RS,TEMP,TS,XS
  S IENB=DA_","_DA(1)_","
- S OPER="!&-+<>='"
+ S OPER="!&<>='"
  S XS=$$PSPACE(X)
  D POSTFIX^PXRMSTAC(XS,OPER,.PFSTACK)
@@ -140,14 +140,11 @@
 PSPACE(OPR) ;OPR is an operand in a function finding, if some portion
  ;of OPR is a string translate a space into "~" so it is preserved.
- ;Note this will work for the entire function string.
- N DONE,END,START,TNS,TS
- S DONE=0,END=1
- F  Q:DONE  D
- . S START=$F(OPR,"""",END)
- . I START=0 S DONE=1 Q
- . S END=$F(OPR,"""",START)
- . S TS=$E(OPR,START,END-2)
- . S TNS=$TR(TS," ","~")
- . S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
+ N END,START,TNS,TS
+ S START=$F(OPR,"""")
+ I START=0 Q OPR
+ S END=$F(OPR,"""",START)-2
+ S TS=$E(OPR,START,END)
+ S TNS=$TR(TS," ","~")
+ S OPR=$$STRREP^PXRMUTIL(OPR,TS,TNS)
  Q OPR
  ;
@@ -198,5 +195,5 @@
  N DAI,DATE,FUNIEN,IND,LIST,MFUN,OPER,PFSTACK,TEMP,TEXT,VALID
  S DAI=DA(1)
- S OPER="!&-+<>='"
+ S OPER="!&<>='"
  ;Define the allowed M functions.
  S MFUN("$P")=""
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMGECN.m	(revision 636)
@@ -1,8 +1,8 @@
-PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;06/01/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMGECN ;SLC/JVS GEC-Score Reports-cont'd ;6/19/03  20:58
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  Q
 SUM ;By Summary by Patient
  N CAT,HF,DATE,DFN,Y,HFN,CNTREF,X,REFNUM,SUM,GSUM,CATDANA
- N DATER,SDATE,SCNT
+ N DATER,SDATE
  D E^PXRMGECV("HS1",1,BDT,EDT,"F",DFNONLY)
  I FORMAT="D" S FOR=0
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMHF.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMHF ; SLC/PKR - Handle Health Factor findings. ;06/01/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMHF ; SLC/PKR - Handle Health Factor findings. ;12/23/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;=====================================================
@@ -142,5 +142,4 @@
  N EM,FIEN,IND,JND,LVL,NOUT,PNAME,TEMP,TEXTOUT,VDATE
  S FIEN=$P(IFIEVAL("FINDING"),";",1)
- ;DBIA #3083
  S PNAME=$P(^AUTTHF(FIEN,0),U,1)
  S NLINES=NLINES+1
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDC.m	(revision 636)
@@ -1,9 +1,9 @@
-PXRMINDC ; SLC/PKR - Index counting routines. ;03/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDC ; SLC/PKR - Index counting routines. ;04/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;========================================================
 CNT5(FILENUM,COUNT) ;Get date counts for indexes where the date
  ;is at subscript 5. Works for file numbers:
- ;63, 70, 120.5, 601.2, 601.84,
+ ;63, 70, 120.5, 601.2,
  ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
  N DAS,DATE,DFN,IND,ITEM,YEAR
@@ -177,5 +177,4 @@
  S ROUTINE(120.5)="CNT5^PXRMINDC"
  S ROUTINE(601.2)="CNT5^PXRMINDC"
- S ROUTINE(601.84)="CNT5^PXRMINDC"
  S ROUTINE(9000011)="CNTPL^PXRMINDC"
  S ROUTINE(9000010.07)="CNT6^PXRMINDC"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDD.m	(revision 636)
@@ -1,9 +1,9 @@
-PXRMINDD ; SLC/PKR - Index string date checking routines. ;03/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDD ; SLC/PKR - Index string date checking routines. ;05/02/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;========================================================
 CNT5(FILENUM,NSD) ;Check for string dates for indexes where the date
  ;is at subscript 5. Works for file numbers:
- ;63, 70, 120.5, 601.2, 601.84
+ ;63, 70, 120.5, 601.2,
  ;9000010.11, 9000010.12, 9000010.13, 9000010.16, 9000010.23
  N DAS,DATE,DFN,IND,ITEM
@@ -177,5 +177,4 @@
  S ROUTINE(120.5)="CNT5^PXRMINDD"
  S ROUTINE(601.2)="CNT5^PXRMINDD"
- S ROUTINE(601.84)="CNT5^PXRMINDD"
  S ROUTINE(9000011)="CNTPL^PXRMINDD"
  S ROUTINE(9000010.07)="CNT6^PXRMINDD"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDL.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMINDL ; SLC/PKR - List building routines. ;07/26/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDL ; SLC/PKR - List building routines. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;================================================
 EVALPL(FINDPA,ENODE,TERMARR,PLIST) ;General patient list term evaluator.
@@ -25,5 +25,5 @@
  N DAS,DATE,DFN,DS,NFOUND
  K ^TMP($J,PLIST)
- I FILENUM=601.84 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
+ I FILENUM=601.2 D SEVALPL^PXRMMH(ITEM,NOCC,BDT,EDT,PLIST) Q
  S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
  S DFN=0
@@ -84,10 +84,8 @@
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
  S INVFD=$P(PFINDPA(0),U,16)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D GETSTATI^PXRMSTAT(FILENUM,.PFINDPA,.STATUSA)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
- ;Ignore any negative occurrence counts, date reversal not allowed
- ;in patient lists.
- S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
- S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  I SSFIND D FPLISTSS(FILENUM,SNODE,ITEM,NGET,BDT,EDT,USESTRT,TGLIST)
  I 'SSFIND D FPLIST(FILENUM,SNODE,ITEM,NGET,BDT,EDT,TGLIST)
@@ -104,5 +102,5 @@
  .. I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
  ..;If this is a Mental Health finding attach the scale to DAS.
- .. I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
+ .. I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
  .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
  .. S VALUE=$G(FIEVD("VALUE"))
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMINDX.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;10/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMINDX ; SLC/PKR - Routines for utilizing the index. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;Code for patient findings.
  ;================================================================
@@ -58,5 +58,5 @@
  S SDIR=$S(NOCC<0:+1,1:-1)
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
- S NGET=$S(UCIFS:50,1:NOCC)
+ S NGET=$S(UCIFS:"*",1:NOCC)
  ;Determine if this is a finding with a start and stop date.
  S SSFIND=$S(FILENUM=52:1,FILENUM["55":1,FILENUM=100:1,1:0)
@@ -75,5 +75,5 @@
  . I PFINDPA(0)["LAB(60" S DAS=ITEM_"~"_DAS
  .;If this is a Mental Health finding attach the scale to DAS.
- . I PFINDPA(0)["YTT(601.71" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
+ . I PFINDPA(0)["YTT(601" S DAS=DAS_"S"_$P(PFINDPA(0),U,12)
  . D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
  . I INVFD D GETDATA^PXRMVSIT(FIEVD("VISIT"),.FIEVD,0)
@@ -101,5 +101,5 @@
  ;data for regular files. FLIST is returned in date order, i.e.,
  ;FLIST(1) is the most recent SDIR=-1, oldest SDIR=+1.
- I FILENUM=601.84 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
+ I FILENUM=601.2 D SEVALFI^PXRMMH(DFN,ITEM,NGET,SDIR,BDT,EDT,.NFOUND,.FLIST) Q
  N DAS,DATE,DONE,EDTT
  S EDTT=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMISE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMISE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMISE.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMISE ; SLC/PKR - Index size estimating routines. ;03/13/2006
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMISE ; SLC/PKR - Index size estimating routines. ;01/12/2005
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;========================================================
@@ -37,6 +37,5 @@
  W !,"Queue the Clinical Reminders index size estimation."
  S DIR("A",1)="Enter the date and time you want the job to start."
- S DIR("A",2)="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")
- S DIR("A")="Start the task at: "
+ S DIR("A")="It must be after "_$$FMTE^XLFDT(MINDT,"5Z")_" "
  S DIR(0)="DAU"_U_MINDT_"::RSX"
  D ^DIR
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLCD.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;11/02/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLCD ; SLC/PKR - Reminder Patient List Patients ;06/30/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Display list creation documentation.
@@ -12,5 +12,5 @@
  S IND="",PXRMDONE=0
  F  S IND=$O(VALMY(IND)) Q:(IND="")!(PXRMDONE)  D
- . S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ . S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  . D EN^PXRMLCD(LISTIEN)
  S VALMBCK="R"
@@ -40,6 +40,5 @@
  ;===========================================================
 HDR ; Header code
- S VALMHDR(1)="Documentation for creation of patient list:"
- S VALMHDR(2)=" "_$P(^PXRMXP(810.5,LISTIEN,0),U,1)
+ S VALMHDR(1)="Documentation for creation of patient list "_$P(^PXRMXP(810.5,LISTIEN,0),U,1)
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLCR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 10/18/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLCR ; SLC/PJH - Create Patient List from individual finding rule; 08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ; Called from PXRM PATIENT LIST CREATE protocol
@@ -37,5 +37,4 @@
 TPAT S PXRMTPAT=$$ASKYN^PXRMEUT("N","Include test patients on the list")
  Q:$D(DTOUT)  G:$D(DUOUT) DPAT
- I $G(PXRMDEBG) D RUN^PXRMLCR(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) Q
  ;Build patient list in background
  N ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
@@ -85,7 +84,7 @@
  ;
  I CALL=4 D
- .S HTEXT(1)="Enter Y to turn on debug output."
- .S HTEXT(2)="The debug output will send a series of MailMan messages to the requestor of the report"
- .S HTEXT(3)="-**WARNING**- the reminder report will take longer to run if you turn on this option!"
+ .S HTEXT(1)="Enter Y to turn on Debug output."
+ .S HTEXT(2)="The debug output will send a series of mailman message to the requestor of the report"
+ .S HTEXT(3)="**WARNING** the reminder report will take longer to run if you turn on this option!"
  D HELP^PXRMEUT(.HTEXT)
  Q
@@ -96,7 +95,5 @@
  S DIC("A")=TEXT
  S DIC("S")="I $P($G(^(100)),U)'=""N"""
- ;If this is a new entry save the creator, make the TYPE public and
- ;CLASS local.
- S DIC("DR")=".07///`"_DUZ_";.08///PUB;100///L"
+ S DIC("DR")="100///L"
  W !
  D ^DIC
@@ -158,5 +155,5 @@
 RUN(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,PXRMDPAT,PXRMTPAT) ;
  ;Process rule set and update final patient list
- D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT,"")
+ D START^PXRMRULE(PXRMRULE,PXRMLIST,PXRMNODE,BEG,END,"","","",PXRMDPAT,PXRMTPAT)
  ;Clear ^TMP lists created for rule
  D CLEAR^PXRMRULE(PXRMRULE,PXRMNODE)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLIST.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLIST ; SLC/PKR/PJH - Clinical Reminders list functions. ;07/17/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMLIST ; SLC/PKR/PJH - Clinical Reminders list functions. ;10/04/2000
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;Used in the reminder exchange utility for building lists of
  ;reminders, Exchange File entries, etc.
@@ -11,14 +11,15 @@
  ;
  ;=======================================================
-FMT(NUMBER,NAME,SOURCE,DATE,FMTSTR,NL,OUTPUT) ;Format  entry number, name,
- ;source, and date packed for LM display.
- N TEMP,TSOURCE
- S TEMP=NUMBER_U_NAME
+FRE(NUMBER,NAME,SOURCE,DATE) ;Format  entry number, name, source,
+ ;and date packed.
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,4," ")
+ S TNAME=$E(NAME,1,27)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,29," ")
  S TSOURCE=$E($P(SOURCE,",",1),1,12)_"@"_$E($P(SOURCE," at ",2),1,12)
- S TEMP=TEMP_U_TSOURCE
+ S TEMP=TEMP_$$LJ^XLFSTR(TSOURCE,23," ")
  S DATE=$$FMTE^XLFDT(DATE,"5Z")
- S TEMP=TEMP_U_DATE
- D COLFMT^PXRMTEXT(FMTSTR,TEMP," ",.NL,.OUTPUT)
- Q
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DATE,30," ")
+ Q TEMP
  ;
  ;=======================================================
@@ -74,22 +75,18 @@
  ;
  ;=======================================================
-REXL(RLIST) ;Build a list of exchange repository entries.
- N DATE,EXIEN,FMTSTR,IND,NAME,NL,NUM,OUTPUT,SOURCE,STR
+RE(RLIST,IEN) ;Build a list of repository entries.
+ N DATE,IND,NAME,SOURCE
  ;Build the list in alphabetical order.
- S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLL")
- S (NUM,VALMCNT)=0
+ S VALMCNT=0
  S NAME=""
  F  S NAME=$O(^PXD(811.8,"B",NAME)) Q:NAME=""  D
  . S DATE=""
  . F  S DATE=$O(^PXD(811.8,"B",NAME,DATE)) Q:DATE=""  D
- .. S EXIEN=$O(^PXD(811.8,"B",NAME,DATE,""))
- .. S SOURCE=$P(^PXD(811.8,EXIEN,0),U,2)
- .. S NUM=NUM+1
- .. S ^TMP(RLIST,$J,"SEL",NUM)=EXIEN
- .. D FMT(NUM,NAME,SOURCE,DATE,FMTSTR,.NL,.OUTPUT)
- .. F IND=1:1:NL D
- ... S VALMCNT=VALMCNT+1,^TMP(RLIST,$J,VALMCNT,0)=OUTPUT(IND)
- ... S ^TMP(RLIST,$J,"IDX",VALMCNT,NUM)=""
- S ^TMP(RLIST,$J,"VALMCNT")=VALMCNT
+ .. S IND=$O(^PXD(811.8,"B",NAME,DATE,""))
+ .. S SOURCE=$P(^PXD(811.8,IND,0),U,2)
+ .. S VALMCNT=VALMCNT+1
+ .. S RLIST(VALMCNT,0)=$$FRE(VALMCNT,NAME,SOURCE,DATE)
+ .. S IEN(VALMCNT)=IND
+ S RLIST("VALMCNT")=VALMCNT
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLLED.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLLED ; SLC/PJH - Edit a location list. ;06/25/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLLED ; SLC/PJH - Edit a location list. ;12/23/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;================================================================
@@ -64,5 +64,5 @@
  S DR(2,810.9001)=".01;1"
  D ^DIE
- I $D(Y) G RD
+ I $D(Y) G DES
  ;
  ;Hospital Locations
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCF.m	(revision 636)
@@ -1,48 +1,43 @@
-PXRMLOCF ; SLC/PKR - Handle location findings. ;10/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLOCF ; SLC/PKR - Handle location findings. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;This routine is for location list patient findings.
  ;=================================================
 ALL(FILENUM,DFN,PFINDPA,FIEVAL) ;Get all Visits with a location
  ;for a patient.
- N BDT,BTIME,CASESEN,COND,CONVAL,DAS,DATE,DEND,DONE,DS,EDT,FIEVD
- N ICOND,INVBD,INVDATE,INVDT,INVED,NFOUND,NOCC
- N SAVE,SDIR,TEMP,TIME,UCIFS
+ N BDT,CASESEN,COND,CONVAL,DAS,DATE,DONE,EDT,ENTYPE,FIEVD,HLOC
+ N ICOND,IND,NFOUND,NOCC
+ N SAVE,SDIR,TEMP,UCIFS,VDATE
  ;Set the finding search parameters.
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
- S SDIR=$S(NOCC<0:-1,1:1)
+ S SDIR=$S(NOCC<0:+1,1:-1)
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
  S (DONE,NFOUND)=0
- S DEND=$S(EDT[".":EDT,1:EDT+.235959)
- S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
- S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
- I SDIR=1 S DS=INVED-.000001
- I SDIR=-1 S DS=INVBD+.000001
- S INVDT=DS,(DONE,NFOUND)=0
+ I SDIR=1 S VDATE=BDT-.0000001
+ I SDIR=-1 S VDATE=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
  ;DBIA 2028
- F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(DONE)!(INVDT="")  D
- . S INVDATE=$P(INVDT,".",1)
- . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
- . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
- . S TIME="."_$P(INVDT,".",2)
- . I INVDATE=INVED,TIME>ETIME Q
- . I INVDATE=INVBD,TIME<BTIME Q
- . S DAS=0
- . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D
- .. D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
- .. S CONVAL=$S(COND="":1,1:$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD))
- .. S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
- .. I SAVE D
- ... S TEMP=^AUPNVSIT(DAS,0)
- ... S NFOUND=NFOUND+1
- ... S FIEVAL(NFOUND)=CONVAL
- ... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
- ... S FIEVAL(NFOUND,"DAS")=DAS
- ... S FIEVAL(NFOUND,"DATE")=$P(TEMP,U,1)
- ... M FIEVAL(NFOUND)=FIEVD
- ... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
- ... I NFOUND=NOCC S DONE=1
+ F  S VDATE=+$O(^AUPNVSIT("AET",DFN,VDATE),SDIR) Q:(VDATE=0)!(DONE)  D
+ . I SDIR=1,VDATE>EDT S DONE=1 Q
+ . I SDIR=-1,VDATE<BDT S DONE=1 Q
+ . S HLOC=""
+ . F  S HLOC=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC)) Q:(HLOC="")!(DONE)  D
+ .. S ENTYPE=""
+ .. F  S ENTYPE=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC,ENTYPE)) Q:(ENTYPE="")!(DONE)  D
+ ... S DAS=0
+ ... F  S DAS=$O(^AUPNVSIT("AET",DFN,VDATE,HLOC,ENTYPE,DAS)) Q:(DAS="")!(DONE)  D
+ .... D GETDATA^PXRMDATA(FILENUM,DAS,.FIEVD)
+ .... S CONVAL=$S(COND'="":$$COND^PXRMCOND(CASESEN,ICOND,VSLIST,.FIEVD),1:1)
+ .... S SAVE=$S('UCIFS:1,(UCIFS&CONVAL):1,1:0)
+ .... I SAVE D
+ ..... S NFOUND=NFOUND+1
+ ..... S FIEVAL(NFOUND)=CONVAL
+ ..... I COND'="" S FIEVAL(NFOUND,"CONDITION")=CONVAL
+ ..... S FIEVAL(NFOUND,"DAS")=DAS
+ ..... S FIEVAL(NFOUND,"DATE")=VDATE
+ ..... M FIEVAL(NFOUND)=FIEVD
+ ..... I $G(PXRMDEBG) M FIEVAL(NFOUND,"CSUB")=FIEVD
+ ..... I NFOUND=NOCC S DONE=1
  ;Save the finding result.
- D SFRES^PXRMUTIL(-SDIR,NFOUND,.FIEVAL)
+ D SFRES^PXRMUTIL(SDIR,NFOUND,.FIEVAL)
  S FIEVAL("FILE NUMBER")=FILENUM
  Q
@@ -92,11 +87,11 @@
  ;Set the finding search parameters.
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
- S SDIR=$S(NOCC<0:-1,1:1)
+ S SDIR=$S(NOCC<0:+1,1:-1)
+ S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  D SCPAR^PXRMCOND(.PFINDPA,.CASESEN,.COND,.UCIFS,.ICOND,.VSLIST)
- S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
- S NGET=$S(UCIFS:50,$D(STATUSA):50,1:NOCC)
+ S NGET=$S(UCIFS:"*",$D(STATUSA):"*",1:NOCC)
  ;Get a list of unique locations.
  D LOCLIST(ITEM,"HLOCL")
- D FPDAT(DFN,"HLOCL",NGET,SDIR,BDT,EDT,.NFOUND,.FLIST)
+ D FPDAT(DFN,"HLOCL",NGET,BDT,EDT,.NFOUND,.FLIST)
  I NFOUND=0 S FIEVAL=0 Q
  S NP=0
@@ -121,45 +116,31 @@
  ;
  ;=================================================
-FPDAT(DFN,HLOCL,NOCC,SDIR,BDT,EDT,NFOUND,FLIST) ;Find patient data for
+FPDAT(DFN,HLOCL,NOCC,BDT,EDT,NFOUND,FLIST) ;Find patient data for
  ;visits at a specified hospital location. Return up to NOCC most
  ;recent entries in FLIST where FLIST(1) is the most recent.
- ;"AA" in Visit file is inverse date_.time instead of a full inverse
- ;date and time. For example if the date/time is 3030704.104449 then
- ;"AA" has 6969295.104449 instead of 6969295.89555
- N BTIME,DAS,DATE,DEND,DLIST,DONE,DS,ETIME,HLOC
- N INVBD,INVDATE,INVDT,INVED,NF,TEMP,TIME
- S DEND=$S(EDT[".":EDT,1:EDT+.235959)
- S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
- S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
- I SDIR=1 S DS=INVED-.000001
- I SDIR=-1 S DS=INVBD+.000001
- ;DBIA #2028
- S INVDT=DS,(DONE,NFOUND)=0
- F  S INVDT=$O(^AUPNVSIT("AA",DFN,INVDT),SDIR) Q:(INVDT="")!(DONE)  D
+ N DAS,DATE,DLIST,ENTYPE,HLOC,NF
+ S NFOUND=0
+ S DATE=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
+ ;DBIA 2028
+ F  S DATE=+$O(^AUPNVSIT("AET",DFN,DATE),-1) Q:(DATE=0)!(DATE<BDT)!(NFOUND=NOCC)  D
+ . S HLOC=""
+ . F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:(HLOC="")!(NFOUND=NOCC)  D
+ .. I '$D(^AUPNVSIT("AET",DFN,DATE,HLOC)) Q
+ .. S NF=0
+ .. S ENTYPE=""
+ .. F  S ENTYPE=$O(^AUPNVSIT("AET",DFN,DATE,HLOC,ENTYPE)) Q:(ENTYPE="")!(NFOUND=NOCC)  D
+ ... S DAS=0
+ ... F  S DAS=$O(^AUPNVSIT("AET",DFN,DATE,HLOC,ENTYPE,DAS)) Q:(DAS="")!(NFOUND=NOCC)  D
+ ....;Check the associated appointment for a valid status.
+ .... I '$$VAPSTAT^PXRMVSIT(DAS) Q
+ .... S NF=NF+1,NFOUND=NFOUND+1
+ .... S DLIST(DATE,NF)=DAS
+ S NFOUND=0
+ S DATE=""
+ F  S DATE=$O(DLIST(DATE),-1) Q:DATE=""  D
  . S NF=0
- . S INVDATE=$P(INVDT,".",1)
- . I (SDIR=1),INVDATE>INVBD S DONE=1 Q
- . I (SDIR=-1),INVDATE<INVED S DONE=1 Q
- . S TIME="."_$P(INVDT,".",2)
- . I INVDATE=INVED,TIME>ETIME Q
- . I INVDATE=INVBD,TIME<BTIME Q
- . S DAS=0
- . F  S DAS=$O(^AUPNVSIT("AA",DFN,INVDT,DAS)) Q:(DAS="")!(DONE)  D
- .. S TEMP=^AUPNVSIT(DAS,0)
- .. S HLOC=$P(TEMP,U,22)
- .. I HLOC="" Q
- .. I '$D(^TMP($J,HLOCL,HLOC)) Q
- ..;Check the associated appointment for a valid status.
- .. I '$$VAPSTAT^PXRMVSIT(DAS) Q
- .. S DATE=$P(TEMP,U,1)
- .. S NF=NF+1,NFOUND=NFOUND+1
- .. I NFOUND=NOCC S DONE=1
- .. S DLIST(INVDT,NF)=DAS_U_DATE
- S INVDT="",NFOUND=0
- F  S INVDT=$O(DLIST(INVDT)) Q:INVDT=""  D
- . S NF=0
- . F  S NF=$O(DLIST(INVDT,NF)) Q:NF=""  D
+ . F  S NF=$O(DLIST(DATE,NF)) Q:NF=""  D
  .. S NFOUND=NFOUND+1
- .. S FLIST(NFOUND)=DLIST(INVDT,NF)
+ .. S FLIST(NFOUND)=DLIST(DATE,NF)_U_DATE
  K ^TMP($J,"HLOCL")
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCL.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOCL.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLOCL.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLOCL ; SLC/PKR - Handle location findings. ;07/26/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLOCL ; SLC/PKR - Handle location findings. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;This routine is for location list patient lists.
  ;=============================================
@@ -33,14 +33,14 @@
  ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
  N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
- N NFOUND,SC,TEMP,TGLIST,TIME
+ N NFOUND,TEMP,TGLIST,TIME
  S TGLIST="FPLIST_PXRMLOCL"
  K ^TMP($J,TGLIST)
- S DEND=$S(EDT[".":EDT,1:EDT+.235959)
+ S DEND=$S(EDT[".":EDT,1:EDT+.240001)
  ;"AHL" in Visit file is inverse date_.time instead of a full inverse
  ;date and time. For example if the date/time is 3030704.104449 then
  ;"AHL" has 6969295.104449 instead of 6969295.89555
- S INVBD=9999999-$P(BDT,".",1),BTIME="."_$P(BDT,".",2)
- S INVED=9999999-$P(DEND,".",1),ETIME="."_$P(DEND,".",2)
- S DS=INVED-.000001
+ S INVBD=9999999-$P(BDT,".",1),BTIME=+("."_$P(BDT,".",2))
+ S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
+ S DS=INVED-1
  S HLOC=""
  F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
@@ -50,7 +50,7 @@
  .. S INVDATE=$P(INVDT,".",1)
  .. I INVDATE>INVBD S DONE=1 Q
- .. S TIME="."_$P(INVDT,".",2)
+ .. S TIME=+("."_$P(INVDT,".",2))
  .. I INVDATE=INVED,TIME>ETIME Q
- .. I INVDATE=INVBD,TIME<BTIME Q
+ .. I INVDATE=INVBD,BTIME>TIME S DONE=1 Q
  .. S DAS=0
  .. F  S DAS=$O(^AUPNVSIT("AHL",HLOC,INVDT,DAS)) Q:DAS=""  D
@@ -58,8 +58,7 @@
  ... I '$$VAPSTAT^PXRMVSIT(DAS) Q
  ... S TEMP=^AUPNVSIT(DAS,0)
+ ... S DFN=$P(TEMP,U,5)
  ... S DATE=$P(TEMP,U,1)
- ... S DFN=$P(TEMP,U,5)
- ... S SC=$P(TEMP,U,7)
- ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC_U_SC
+ ... S ^TMP($J,TGLIST,DFN,INVDT,DAS)=DATE_U_HLOC
  ;Return the NOCC most recent for each patient.
  S DFN=0
@@ -75,35 +74,4 @@
  ;
  ;=============================================
-FTEST(FILENUM,HLOCL,NOCC,BDT,EDT,PLIST) ;Find patient list data for
- ;a visit to a hospital location. Return the list in ^TMP($J,PLIST).
- N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
- N NFOUND,TEMP,TGLIST,TIME
- S TGLIST="FPLIST_PXRMLOCL"
- K ^TMP($J,TGLIST)
- S DS=$S(EDT[".":EDT+.0000001,1:EDT+.240001)
- S HLOC=""
- F  S HLOC=$O(^TMP($J,HLOCL,HLOC)) Q:HLOC=""  D
- . S DATE=DS
- . F  S DATE=+$O(^AUPNVSIT("AHDP",HLOC,DATE),-1) Q:(DATE=0)!(DATE<BDT)  D
- .. S DFN=""
- .. F  S DFN=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN)) Q:DFN=""  D
- ... S SC=""
- ... F  S SC=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN,SC)) Q:SC=""  D
- .... S DAS=$O(^AUPNVSIT("AHDP",HLOC,DATE,DFN,SC,""))
- .... I '$$VAPSTAT^PXRMVSIT(DAS) Q
- .... S ^TMP($J,TGLIST,DFN,DATE,DAS)=HLOC
- ;Return the NOCC most recent for each patient.
- S DFN=0
- F  S DFN=$O(^TMP($J,TGLIST,DFN)) Q:DFN=""  D
- . S DATE="",NFOUND=0
- . F  S DATE=$O(^TMP($J,TGLIST,DFN,DATE),-1) Q:(NFOUND=NOCC)!(DATE="")  D
- .. S DAS=""
- .. F  S DAS=$O(^TMP($J,TGLIST,DFN,DATE,DAS)) Q:(NFOUND=NOCC)!(DAS="")  D
- ... S NFOUND=NFOUND+1
- ... S ^TMP($J,PLIST,DFN,NFOUND)=DAS_U_DATE_U_^TMP($J,TGLIST,DFN,DATE,DAS)
- K ^TMP($J,TGLIST)
- Q
- ;
- ;=============================================
 GPLIST(FILENUM,SNODE,ITEM,PFINDPA,PLIST) ;Add to the patient list.
  ; Return the list in ^TMP($J,PLIST).
@@ -115,9 +83,7 @@
  ;Set the finding search parameters.
  D SSPAR^PXRMUTIL(PFINDPA(0),.NOCC,.BDT,.EDT)
- ;Ignore negative occurrence count, date reversal not allowed in
- ;patient lists.
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
  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)
  ;Get a list of unique locations.
  S LNAME=$P(^PXRMD(810.9,ITEM,0),U,1)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPAU.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLPAU ; SLC/AGP - Reminder Patient List ;09/06/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMLPAU ; SLC/AGP - Reminder Patient List ;07/29/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;Main entry point for PXRM PATIENT LIST
@@ -83,5 +83,5 @@
  Q
  ;
-ADD ;add a user
+ADD ;add a users
  N CREAT,CNT,DIC,DIE,FDA,MSG,USER,Y
  S CREAT=$P($G(^PXRMXP(810.5,IEN,0)),U,7)
@@ -105,5 +105,5 @@
  I $D(DIROUT) S DTOUT=1
  I $D(DTOUT)!($D(DUOUT)) Q
- I $G(Y)="" W !,"A level of control must be entered." H 2 Q
+ I $G(Y)="" W !,"A status must be enter" H 2 Q
  S YESNO=$E(Y(0))
  S FDA(810.54,"+2,"_IEN_",",.01)=USER
@@ -146,9 +146,11 @@
 HELP(CALL) ;General help text routine
  N HTEXT
+ ;
  I CALL=1 D
- .S HTEXT(1)="Select CO to copy the patient list.\\"
- .S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
- .S HTEXT(3)="Select DE to delete the patient list.\\"
- .S HTEXT(4)="Select DSP to display the patient list.\\"
+ .S HTEXT(1)="Select CO to copy patient list."
+ .S HTEXT(2)="Select COE to copy patient list to OE/RR Team."
+ .S HTEXT(3)="Select CR to delete patient list."
+ .S HTEXT(4)="Select DSP to display patient list."
+ ;
  D HELP^PXRMEUT(.HTEXT)
  Q
@@ -161,5 +163,5 @@
  N CREAT,IND,LISTIEN,NODE
  I DUZ'=$P($G(^PXRMXP(810.5,IEN,0)),U,7) D  G PDELEX
- .W !,"Only the creator of this list can delete it." H 2
+ .W !,"Only the creator of this list can delete an user." H 2
  D EN^VALM2(XQORNOD(0))
  ;If there is no list quit.
@@ -170,5 +172,5 @@
  .S LISTIEN=^TMP("PXRMLPAU",$J,"IDX",IND,IND)
  .S DA(1)=IEN,DA=LISTIEN,DIK="^PXRMXP(810.5,"_DA(1)_",40," D ^DIK
- .W !,"Patient list deleted"
+ .W !,"PATIENT DELETED"
  ;
 PDELEX ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPHS.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLPHS ; SLC/PJH,PKR - Run Health Summaries from Patient List ;03/26/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLPHS ; SLC/PJH,PKR - Run Health Summaries from Patient List ;08/08/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ;External Ref DBIA #398
@@ -60,5 +60,5 @@
  ;
 QUE(HSIEN,PLNODE) ;Determine whether the report should be queued.
- N PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE
+ N PXRMQUE,RETZTSK,%ZIS,ZTDESC,ZTRTN,ZTSK,ZTSAVE
  S %ZIS="M"
  S ZTDESC="Patient List Health Summaries - print"
@@ -66,5 +66,6 @@
  S ZTSAVE("HSIEN")=""
  S ZTSAVE("PLNODE")=""
- S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,1)
+ S RETZTSK=1
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.RETZTSK)
  S VALMBCK="R"
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPP.m	(revision 636)
@@ -1,8 +1,8 @@
-PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;04/04/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLPP ; SLC/PKR/PJH - Reminder Patient List Patients ;01/06/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM PATIENT LIST
 START(IEN) ;
- N CDATE,CLASS,CREATOR,INDP,INTP,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE
+ N CDATE,CLASS,CREATOR,LDATA,LNAME,PXRMVIEW,SNAME,SOURCE,TYPE
  N VALMBCK,VALMBG,VALMCNT,VALMSG,X,XMZ,XQORM,XQORNOD
  ;Get Patient List record and associated data.
@@ -33,6 +33,4 @@
  S CLASS=$P($G(^PXRMXP(810.5,IEN,100)),U)
  S CLASS=$S(CLASS="N":"National",CLASS="V":"VISN",1:"Local")
- S INDP=$P(LDATA,U,11)
- S INTP=$P(LDATA,U,12)
  ;Default view by name.
  S PXRMVIEW="N"
@@ -90,21 +88,15 @@
  Q
  ;
-FRE(NUMBER,PNAME,DFN,DECEASED,TESTP,INST) ;Format  entry number, name, primary
- ;station and deceased, test information.
- N TEMP,TEXT,TNAME,TSOURCE
- S TEXT=$$RJ^XLFSTR(NUMBER,5," ")
- S TEXT=$$SETFLD^VALM1(PNAME,TEXT,"HEADER1")
- S TEXT=TEXT_"  "_$$LJ^XLFSTR(DFN,15," ")
- S TEMP=""
- I DECEASED S TEMP=" (D)"
- I TESTP S TEMP=" (T)"
- I DECEASED,TESTP S TEMP=" (DP)"
- S TEXT=TEXT_TEMP
- I INST'="" S TEXT=$$SETFLD^VALM1(INST,TEXT,"HEADER3")
- Q TEXT
+FRE(NUMBER,NAME,INST,DFN) ;Format  entry number, name and primary station
+ N TEMP,TNAME,TSOURCE
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S TNAME=$E(NAME,1,30)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(TNAME,32," ")
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DFN,15," ")
+ I INST'="" S TEMP=TEMP_"  "_INST
+ Q TEMP
  ;
 HDR ; Header code
- N TEXT
- S VALMHDR(1)="List Name: "_LNAME
+ S VALMHDR(1)="List Name: "_LNAME_" ("_VALMCNT_" patients)"
  S VALMHDR(2)=" Created: "_$$FMTE^XLFDT(CDATE,"5Z")
  S VALMHDR(2)=$$LJ^XLFSTR(VALMHDR(2),40)_"Creator: "_CREATOR
@@ -112,12 +104,5 @@
  S VALMHDR(3)=$$LJ^XLFSTR(VALMHDR(3),40)_"Type: "_TYPE
  S VALMHDR(4)=" Source: "_SNAME
- S VALMHDR(5)=" Number of patients: "_VALMCNT
  S VALMSG="+ Next Screen   - Prev Screen   ?? More Actions"
- S TEXT=""
- I INDP S TEXT=" (D=deceased)"
- I INTP S TEXT=" (T=test)"
- I INDP,INTP S TEXT=" (D=deceased, T=test)"
- S TEXT="DFN"_TEXT
- D CHGCAP^VALM("HEADER2",TEXT)
  Q
  ;
@@ -148,5 +133,4 @@
  .;DBIA #10035
  .S PNAME=$P(^DPT(DFN,0),U,1)
- .I PNAME="" S PNAME=DFN_" does not exist"
  .S ^XTMP(PLNODE,PNAME)=DFN
  D HSI^PXRMLPHS(PLNODE)
@@ -159,5 +143,5 @@
  ;
 LIST(VALMCNT,IEN,INCINST) ;Build a list of patients.
- N DATA,DECEASED,DFN,IND,INST,NEXT,PNAME,SUB,TESTP
+ N DATA,DFN,IND,INST,NEXT,PNAME,SUB
  ;Build the ordered list.
  S IND=0,SUB="NAME"
@@ -165,9 +149,6 @@
  .S DATA=$G(^PXRMXP(810.5,IEN,30,IND,0)) Q:DATA=""
  .S DFN=$P(DATA,U) Q:'DFN
- .S DECEASED=$P(DATA,U,4)
- .S TESTP=$P(DATA,U,5)
  .;#DBIA 10035
  .S PNAME=$P($G(^DPT(DFN,0)),U,1)
- .I PNAME="" S PNAME=DFN_" does not exist"
  .S INSTNUM=$P(DATA,U,2) S:INSTNUM="" INSTNUM="NONE"
  .S INST=$P(DATA,U,3)
@@ -176,5 +157,5 @@
  .I INST="" S INST="NONE"
  .I PXRMVIEW="I" S SUB=INST
- .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=DECEASED_U_TESTP_U_INST
+ .S ^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)=INST
  ;Transfer to list manager array 
  S SUB="",VALMCNT=0
@@ -184,10 +165,7 @@
  ..S DFN=""
  ..F  S DFN=$O(^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)) Q:DFN=""  D
- ...S DATA=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)
- ...S DECEASED=$P(DATA,U,1)
- ...S TESTP=$P(DATA,U,2)
- ...I INCINST S INST=$P(DATA,U,3)
+ ...I INCINST S INST=^TMP("PXRMLPPA",$J,SUB,PNAME,DFN)
  ...S VALMCNT=VALMCNT+1
- ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,DFN,DECEASED,TESTP,INST)
+ ...S ^TMP("PXRMLPP",$J,VALMCNT,0)=$$FRE(VALMCNT,PNAME,INST,DFN)
  ...S ^TMP("PXRMLPPI",$J,VALMCNT)=DFN
  K ^TMP("PXRMLPPA",$J)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLPU.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;10/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLPU ; SLC/PKR/PJH - Reminder Patient List ;08/07/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM PATIENT LIST
@@ -31,10 +31,12 @@
  ;
 BLDLIST ;
- N PLIST
+ N IEN,PLIST
  K ^TMP("PXRMLPU",$J)
  K ^TMP("PXRMLPUH",$J)
  S PLIST="PXRMLPU"
- D LIST(MODE,PLIST)
+ D LIST(MODE,PLIST,.IEN)
  S VALMCNT=+$G(^TMP("PXRMLPU",$J,"VALMCNT"))
+ F IND=1:1:VALMCNT D
+ .S ^TMP("PXRMLPU",$J,"IDX",IND,IND)=IEN(IND)
  Q
  ;
@@ -54,4 +56,19 @@
  Q
  ;
+FORMAT(NUMBER,NAME,NODE) ;Format  entry number, name, source,
+ ;and date packed.
+ N ACCESS,DATE,COUNT,TEMP,TYPE
+ S DATE=$P(NODE,U,2),COUNT=$P(NODE,U,3)
+ S TYPE=$P(NODE,U,4),ACCESS=$P(NODE,U,5)
+ S TEMP=$$RJ^XLFSTR(NUMBER,5," ")
+ S NAME=$E(NAME,1,45)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(NAME,45," ")
+ S DATE=$$FMTE^XLFDT(DATE,2)
+ S TEMP=TEMP_"  "_$$LJ^XLFSTR(DATE,17," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(COUNT,6," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(TYPE,4," ")
+ S TEMP=TEMP_"  "_$$RJ^XLFSTR(ACCESS,3," ")
+ Q TEMP
+ ;
 HDR ; Header code
  N NAME
@@ -62,9 +79,9 @@
  N HTEXT
  I CALL=1 D
- .S HTEXT(1)="Select CO to copy the patient list.\\"
- .S HTEXT(2)="Select COE to copy the patient list to an OE/RR Team.\\"
- .S HTEXT(3)="Select DE to delete the patient list.\\"
- .S HTEXT(4)="Select DCD to display creation documentation.\\"
- .S HTEXT(5)="Select DSP to display the patient list.\\"
+ .S HTEXT(1)="Select CO to copy patient list."
+ .S HTEXT(2)="Select COE to copy patient list to OE/RR Team."
+ .S HTEXT(3)="Select CR to delete patient list."
+ .S HTEXT(4)="Select DCD to display creation documentation."
+ .S HTEXT(5)="Select DSP to display patient list."
  D HELP^PXRMEUT(.HTEXT)
  Q
@@ -80,20 +97,18 @@
  Q
  ;
-LIST(MODE,PLIST) ;Build a list of patient list entries.
- N ACCESS,COUNT,DATA,DATE,IND,FMTSTR,FNAME,OUTPUT,NAME,NL,NUM
- N STR,SUB,TYPE
- S FMTSTR=$$LMFMTSTR^PXRMTEXT(.VALMDDF,"RLLRRC")
+LIST(MODE,PLIST,IEN) ;Build a list of patient list entries.
+ N ACCESS,COUNT,DATE,IND,FNAME,NAME,NODE,SUB,TYPE
  ;MODE=0 build list in alphabetical order
  ;MODE=1 build list by type of list.
  K ^TMP($J,PLIST),^TMP(PLIST,$J)
- S VALMCNT=0,NAME="",NUM=0,TYPE=""
+ S VALMCNT=0,NAME="",TYPE=""
  F  S NAME=$O(^PXRMXP(810.5,"B",NAME)) Q:NAME=""  D
  .S IND="" F  S IND=$O(^PXRMXP(810.5,"B",NAME,IND)) Q:'IND  D
- ..S DATA=$G(^PXRMXP(810.5,IND,0))
- ..S ACCESS=$$ACCESS(IND,DATA)
+ ..S NODE=$G(^PXRMXP(810.5,IND,0))
+ ..S ACCESS=$$ACCESS(IND,NODE)
  ..I ACCESS="N" Q
- ..S FNAME=$P($G(DATA),U),DATE=$P($G(DATA),U,4)
+ ..S FNAME=$P($G(NODE),U),DATE=$P($G(NODE),U,4)
  ..S COUNT=+$P($G(^PXRMXP(810.5,IND,30,0)),U,4)
- ..S TYPE=$P(DATA,U,8)
+ ..S TYPE=$P(NODE,U,8)
  ..S SUB=$S(MODE=0:"NAME",1:TYPE)
  ..S ^TMP($J,PLIST,SUB,FNAME)=IND_U_DATE_U_COUNT_U_TYPE_U_ACCESS
@@ -104,15 +119,9 @@
  S SUB=""
  F  S SUB=$O(^TMP($J,PLIST,SUB),-1) Q:SUB=""  D
- . S FNAME=""
- . F  S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME=""  D
- .. S DATA=^TMP($J,PLIST,SUB,FNAME),NUM=NUM+1
- .. S ^TMP("PXRMLPU",$J,"SEL",NUM)=$P(DATA,U,1)
- .. S DATE=$P(DATA,U,2),DATE=$$FMTE^XLFDT(DATE,2)
- .. S $P(DATA,U,2)=DATE
- .. S STR=NUM_U_FNAME_U_$P(DATA,U,2,5)
- .. D COLFMT^PXRMTEXT(FMTSTR,STR," ",.NL,.OUTPUT)
- .. F IND=1:1:NL D
- ... S VALMCNT=VALMCNT+1,^TMP(PLIST,$J,VALMCNT,0)=OUTPUT(IND)
- ... S ^TMP("PXRMLPU",$J,"IDX",VALMCNT,NUM)=""
+ .S FNAME=""
+ .F  S FNAME=$O(^TMP($J,PLIST,SUB,FNAME)) Q:FNAME=""  D
+ ..S NODE=^TMP($J,PLIST,SUB,FNAME),VALMCNT=VALMCNT+1
+ ..S ^TMP(PLIST,$J,VALMCNT,0)=$$FORMAT(VALMCNT,FNAME,NODE)
+ ..S IEN(VALMCNT)=$P(NODE,U,1)
  S ^TMP(PLIST,$J,"VALMCNT")=VALMCNT
  K ^TMP($J,PLIST)
@@ -136,6 +145,6 @@
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the patient list ien.
- .S LISTIEN=^TMP(SUB,$J,"SEL",IND)
- .D COPY^PXRMRUL1(LISTIEN)
+ .S LISTIEN=^TMP(SUB,$J,"IDX",IND,IND)
+ .D COPY^PXRMRULE(LISTIEN)
  Q
  ;
@@ -150,8 +159,8 @@
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the patient list ien.
- .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
  .S DELOK=$$LDELOK^PXRMEUT(LISTIEN)
- .I DELOK D DELETE^PXRMRUL1(LISTIEN) Q
+ .I DELOK D DELETE^PXRMRULE(LISTIEN) Q
  .E  D  Q
  ..W !,"In order to delete a list you must be the creator or a Reminder Manager!"
@@ -177,5 +186,5 @@
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
  .;Get the patient list ien.
- .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  .S NODE=$G(^PXRMXP(810.5,LISTIEN,0))
  .S ACCESS=$$ACCESS^PXRMLPU(LISTIEN,NODE)
@@ -196,5 +205,5 @@
  S IND=""
  F  S IND=$O(VALMY(IND)) Q:(+IND=0)!(PXRMDONE)  D
- .S LISTIEN=^TMP("PXRMLPU",$J,"SEL",IND)
+ .S LISTIEN=^TMP("PXRMLPU",$J,"IDX",IND,IND)
  .D START^PXRMLPP(LISTIEN)
  D BLDLIST
@@ -227,10 +236,10 @@
  .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 patient list ien
- S LISTIEN=^TMP("PXRMLPU",$J,"SEL",SEL)
+ S LISTIEN=^TMP("PXRMLPU",$J,"IDX",SEL,SEL)
  ;Get extract definition ien (if present)
  S EPIEN=$P($G(^PXRMXP(810.5,LISTIEN,0)),U,5)
@@ -255,5 +264,5 @@
  S DIR("B")="DSP"
  S DIR("?")="Select from the codes displayed. For detailed help type ??"
- S DIR("??")=U_"D HELP^PXRMLPU(1)"
+ S DIR("??")=U_"D HELP^PXRMLPM(1)"
  D ^DIR K DIR
  I $D(DIROUT) S DTOUT=1
@@ -264,5 +273,5 @@
  ;
  ;Copy patient list
- I OPTION="CO" D COPY^PXRMRUL1(LISTIEN)
+ I OPTION="CO" D COPY^PXRMRULE(LISTIEN)
  Q:$D(DUOUT)!$D(DTOUT)
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMLRM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 09/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMLRM ; SLC/PJH/PKR - List Rule Management ; 05/15/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Main entry point for PXRM LIST RULE MANAGEMENT
@@ -56,16 +56,15 @@
  N HTEXT
  I CALL=1 D
- .S HTEXT(1)="Select DE to display or edit a rule.\\"
- .S HTEXT(2)="Select ED to edit a rule.\\"
+ .S HTEXT(1)="Select DE to display or edit a rule."
+ .S HTEXT(2)="Select ED to edit a rule"
  ;
  I CALL=2 D
- .S HTEXT(1)="Select F to edit term based finding rules.\\"
- .S HTEXT(2)="Select P to edit patient list based finding rules.\\"
- .S HTEXT(3)="Select R to edit reminder rules.\\"
- .S HTEXT(4)="Select S to edit rule sets. A rule set may contain"
- .S HTEXT(5)="any of the following:\\"
- .S HTEXT(6)=" finding list rules, patient list rules, reminder rules\\"
- .S HTEXT(7)="These component list rules must be created before the rule set"
- .S HTEXT(8)="can be constructed."
+ .S HTEXT(1)=" Select F to edit term based finding rules."
+ .S HTEXT(2)=" Select P to edit patient list based finding rules."
+ .S HTEXT(3)=" Select R to edit reminder rules."
+ .S HTEXT(4)=" Select S to edit rule sets. A rule set may contain either "
+ .S HTEXT(5)="finding list rules or patient list rules or both. These "
+ .S HTEXT(6)="component list rules must be created before the rule set "
+ .S HTEXT(7)="can be constructed."
  ;
  D HELP^PXRMEUT(.HTEXT)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMMH.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMMH ; SLC/PKR - Handle mental health findings. ;11/23/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMMH ; SLC/PKR - Handle mental health findings. ;04/05/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;=======================================================
@@ -12,5 +12,4 @@
  D EVALPL^PXRMINDL(.FINDPA,ENODE,.TERMARR,PLIST)
  Q
- ;
  ;=======================================================
 EVALTERM(DFN,FINDPA,ENODE,TERMARR,TFIEVAL) ;Evaluate mental
@@ -20,33 +19,37 @@
  ;
  ;=======================================================
-GETDATA(DASP,FIEVT) ;Return the data for a MH Administrations entry.
+GETDATA(DAS,FIEVT) ;Return the data for a Psych Instrument Patient entry.
  ;Some tests require the YSP key in order to get a score.
- N DAS,DATA,IND,SCALE
- S DAS=$P(DASP,"S",1)
- S SCALE=+$P(DASP,"S",2)
- ;DBIA #5043
- D ENDAS71^YTQPXRM6(.DATA,DAS)
- I $G(DATA(1))="[ERROR]" Q
- I SCALE=0 S SCALE=+$O(DATA("SI",""))
- S FIEVT("MH TEST")=$P(DATA(2),U,3)
- S IND=0
- F  S IND=$O(DATA("SI",IND)) Q:IND=""  S FIEVT("S",IND)=$P(DATA("SI",IND),U,3,4)
- S IND=0
- F  S IND=$O(DATA("R",IND)) Q:IND=""  S FIEVT("R",IND)=$P(DATA("R",IND),U,6)
- I $D(DATA("SI",SCALE)) S FIEVT("VALUE")=FIEVT("S",SCALE),FIEVT("SCALE NAME")=$P(DATA("SI",SCALE),U,2)
+ N DASP,IND,SCALE,YSDATA
+ ;DBIA #4442
+ S DASP=$P(DAS,"S",1)
+ S SCALE=$P(DAS,"S",2)
+ D ENDAS^YTAPI10(.YSDATA,DASP)
+ I $G(YSDATA(0))="[ERROR]" Q
+ S FIEVT("MH TEST")=$P(YSDATA(2),U,3)
+ I FIEVT("MH TEST")["GAF" S FIEVT("RATING")=$P(YSDATA(3),U,2) Q
+ ;If no scale is specified use the first set of results.
+ S IND=$S(SCALE="":6,1:SCALE+5)
+ S FIEVT("YSDATA")=$G(YSDATA(IND))
+ S FIEVT("SCALE NAME")=$P(FIEVT("YSDATA"),U,2)
+ S (FIEVT("RAW SCORE"),FIEVT("VALUE"))=$P(FIEVT("YSDATA"),U,3)
+ S FIEVT("TRANSFORMED SCORE")=$P(FIEVT("YSDATA"),U,4)
  Q
  ;
  ;=======================================================
 MHVOUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the MHV output.
- N DATE,IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT
- S MHTEST="Mental Health Test: "_IFIEVAL("MH TEST")_" = "
+ N DATE,IND,JND,MHTEST,NAME,NOUT,RATING,RSCORE,SCORE,TEXTOUT,TSCORE
+ S MHTEST=IFIEVAL("MH TEST")
+ ;Remove the dashes surrounding the name.
+ S MHTEST=$TR(MHTEST,"-","")
+ S NAME="Mental Health Test: "_MHTEST_" = "
  S IND=0
  F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
- . S DATE="("_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))_")"
- . S TEMP=MHTEST_DATE
- . S SNAME=$G(IFIEVAL(IND,"SCALE NAME"))
- . I SNAME'="" S TEMP=TEMP_" scale: "_SNAME_" -"
- . S SCORE=$G(IFIEVAL(IND,"VALUE"))
- . I SCORE'="" S TEMP=TEMP_"  raw score: "_$P(SCORE,U,1)_", transformed score: "_$P(SCORE,U,2)
+ . S DATE=IFIEVAL(IND,"DATE")
+ . S RSCORE=$G(IFIEVAL(IND,"RAW SCORE"))
+ . S TSCORE=$G(IFIEVAL(IND,"TRANSFORMED SCORE"))
+ . S RATING=$G(IFIEVAL(IND,"RATING"))
+ . S SCORE=$S(RATING'="":RATING,TSCORE'="":TSCORE,RSCORE'="":RSCORE,1:"")
+ . S TEMP=NAME_SCORE_" ("_$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))_")"
  . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
@@ -57,15 +60,20 @@
 OUTPUT(INDENT,IFIEVAL,NLINES,TEXT) ;Produce the clinical
  ;maintenance output.
- N IND,JND,MHTEST,NOUT,SCALE,SNAME,SCORE,TEXTOUT
+ N DATE,IND,JND,MHTEST,NOUT,RATING,RSCORE,TEXTOUT,TSCORE
  S MHTEST=IFIEVAL("MH TEST")
+ ;Remove the dashes surrounding the name.
+ S MHTEST=$TR(MHTEST,"-","")
  S NLINES=NLINES+1
  S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Mental Health Test: "_MHTEST
  S IND=0
  F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
+ . S DATE=IFIEVAL(IND,"DATE")
  . S TEMP=$$EDATE^PXRMDATE(IFIEVAL(IND,"DATE"))
- . S SNAME=$G(IFIEVAL(IND,"SCALE NAME"))
- . I SNAME'="" S TEMP=TEMP_" scale: "_SNAME_" -"
- . S SCORE=$G(IFIEVAL(IND,"VALUE"))
- . I SCORE'="" S TEMP=TEMP_"  raw score: "_$P(SCORE,U,1)_", transformed score: "_$P(SCORE,U,2)
+ . S RSCORE=$G(IFIEVAL(IND,"RAW SCORE"))
+ . I RSCORE'="" S TEMP=TEMP_" raw score - "_RSCORE
+ . S TSCORE=$G(IFIEVAL(IND,"TRANSFORMED SCORE"))
+ . I TSCORE'="" S TEMP=TEMP_"; transformed score - "_TSCORE
+ . S RATING=$G(IFIEVAL(IND,"RATING"))
+ . I RATING'="" S TEMP=TEMP_" Rating: "_RATING
  . D FORMATS^PXRMTEXT(INDENT+2,PXRMRM,TEMP,.NOUT,.TEXTOUT)
  . F JND=1:1:NOUT S NLINES=NLINES+1,TEXT(NLINES)=TEXTOUT(JND)
@@ -75,36 +83,27 @@
  ;=======================================================
 SCHELP(MHIEN) ;Xecutable help for MH SCALE
- N DATA,IND,JND,NUM,SCALE,SNUM
+ N IND,JND,NUM,SCALE,TEMP,TEMP1
  I MHIEN=0 D  Q
  . S SCALE(1)="This is not a valid Mental Health finding, selecting an MH scale does"
  . S SCALE(2)="not make sense"
  . D EN^DDIOL(.SCALE)
- ;DBIA #5053
- D SCALES^YTQPXRM5(.DATA,MHIEN)
- I DATA(1)="ERROR" D  Q
- . S SCALE(1)="There are no scales for this test."
- . D EN^DDIOL(.SCALE)
- S SCALE(1)="Valid scales are:"
- S SCALE(2)="SCALE NUMBER  SCALE NAME"
- S SCALE(3)="------------------------"
- S IND=0,JND=3
- F  S IND=$O(DATA("S",IND)) Q:IND=""  D
+ S SCALE(1)="SCALE NUMBER  SCALE NAME"
+ S SCALE(2)="------------------------"
+ S IND=0
+ S JND=2
+ F  S IND=$O(^YTT(601,MHIEN,"S",IND)) Q:+IND=0  D
+ . S TEMP=^YTT(601,MHIEN,"S",IND,0)
  . S JND=JND+1
- . S NUM=6-$L(IND)
- . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_(IND)_"        "_$P(DATA("S",IND),U,1)
+ . S TEMP1=$P(TEMP,U,1)
+ . S NUM=6-$L(TEMP1)
+ . S SCALE(JND)=$$INSCHR^PXRMEXLC(NUM," ")_TEMP1_"        "_$P(TEMP,U,2)
  D EN^DDIOL(.SCALE)
  Q
  ;
  ;=======================================================
-SCHELPD(DA) ;Xecutable help for MH SCALE in Result Group file 801.41
- N MHIEN
- S MHIEN=+$P($G(^PXRMD(801.41,DA,50)),U)
- D SCHELP^PXRMMH(MHIEN)
- Q
- ;=======================================================
 SCHELPF ;Xecutable help for MH SCALE in 811.9 findings.
  N FIND0,MHIEN
  S FIND0=^PXD(811.9,DA(1),20,DA,0)
- I FIND0["YTT(601.71" S MHIEN=$P(FIND0,";",1)
+ I FIND0["YTT(601" S MHIEN=$P(FIND0,";",1)
  E  S MHIEN=0
  D SCHELP(MHIEN)
@@ -115,5 +114,5 @@
  N MHIEN,TFIND0
  S TFIND0=^PXRMD(811.5,DA(1),20,DA,0)
- I TFIND0["YTT(601.71" S MHIEN=$P(TFIND0,";",1)
+ I TFIND0["YTT(601" S MHIEN=$P(TFIND0,";",1)
  E  S MHIEN=0
  D SCHELP(MHIEN)
@@ -121,23 +120,16 @@
  ;
  ;=======================================================
-SCNAME(TEST,SCNUM) ;Given the test ien and scale number return the
- ;scale name.
- N DATA,SCNAME
- D SCALES^YTQPXRM5(.DATA,TEST)
- Q $G(DATA("S",SCNUM))
- ;
- ;=======================================================
 SEVALFI(DFN,ITEM,NGET,SDIR,BDT,EDT,NFOUND,FLIST) ;
- N FIEV,FINDING,IND,YS,DATA
+ N FIEV,FINDING,IND,YS,YSDATA
  S YS("CODE")=ITEM,YS("DFN")=DFN
  S YS("BEGIN")=BDT,YS("END")=EDT
- ;PTTEST^YTQPXRM2 does not understand "*" for a limit so use 99.
+ ;YTAPI10A does not understand "*" for a limit so use 99.
  I NGET="*" S NGET=99
  S YS("LIMIT")=$S(SDIR=-1:NGET,1:-NGET)
- ;DBIA #5035
- D PTTEST^YTQPXRM2(.DATA,.YS)
- S NFOUND=$P(DATA(1),U,2)
+ ;DBIA #4458
+ D PTTEST^YTAPI10A(.YSDATA,.YS)
+ S NFOUND=$P(YSDATA(1),U,2)
  I NFOUND=0 Q
- F IND=1:1:NFOUND S FLIST(IND)=DATA(IND+1)
+ F IND=1:1:NFOUND S FLIST(IND)=YSDATA(IND+1)
  Q
  ;
@@ -147,9 +139,8 @@
  N YS
  ;YTAPI10A does not understand "*" for a limit so use 99.
- ;OCCUR^YTQPXRM1 does not understand "*" for a limit so use 99.
  I NOCC="*" S NOCC=99
  S YS("CODE")=ITEM,YS("BEGIN")=BDT,YS("END")=EDT,YS("LIMIT")=NOCC
- ;DBIA #5034
- D OCCUR^YTQPXRM1(PLIST,.YS)
+ ;DBIA #4458
+ D OCCUR^YTAPI10A(PLIST,.YS)
  Q
  ;
@@ -157,28 +148,13 @@
 VSCALE(X,FIND0) ;Make sure that the mental health scale is valid.
  ;Either the scale number or the scale name can be used.
- N DATA,IND,MHIEN,MHTEST,SCALE,VALID
+ N MHIEN,MHTEST,SCALE,VALID
  S MHTEST=$P(FIND0,U,1)
  S MHIEN=$P(MHTEST,";",1)
- D SCALES^YTQPXRM5(.DATA,MHIEN)
- I +X>0 S VALID=$S($D(DATA("S",X)):1,1:0)
+ I +X>0 D  Q VALID
+ . S VALID=$S($D(^YTT(601,MHIEN,"S",X)):1,1:0)
  E  D
- . S IND=1,VALID=0
- . F  S IND=$O(DATA("S",IND)) Q:(VALID)!(IND="")  D
- .. I X=$P(DATA("S",IND),U,1) S VALID=1 Q
- I 'VALID D EN^DDIOL(X_" is not a valid scale for this test!")
- I $O(DATA(""),-1)>20 H 1
+ . S SCALE=$O(^YTT(601,MHIEN,"S","C",X,""))
+ . S VALID=$S(SCALE="":0,1:1)
  Q VALID
- ;
- ;=======================================================
-VSCALED(X,DA) ;Make sure that the mental health scale is valid for a result
- ;group.
- I X="" Q 1
- ;Do not execute as part of a verify fields.
- I $G(DIUTIL)="VERIFY FIELDS" Q 1
- ;Do not execute as part of exchange.
- I $G(PXRMEXCH) Q 1
- N MHTEST
- S MHTEST=$P($G(^PXRMD(801.41,DA,50)),U)
- Q $$VSCALE(X,MHTEST)
  ;
  ;=======================================================
@@ -205,10 +181,2 @@
  Q $$VSCALE(X,TFIND0)
  ;
- ;=======================================================
-WARN ;Warn the user that they must select a scale if they intend to use
- ;a condition.
- W !,"Remember that the score is returned as raw score^transformed score,"
- W !,"so if your Condition uses the raw score use +V or $P(V,U,1) and if"
- W !,"it uses the transformed score use $P(V,U,2)."
- Q
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMMST.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMMST ; SLC/PKR - Routines for dealing with MST. ;03/29/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMMST ; SLC/PKR - Routines for dealing with MST. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;Use of DGMSTAPI supported by DBIA #2716.
  ;====================================================
@@ -231,5 +231,5 @@
  . I TERMIEN="" Q
  . D TERM^PXRMLDR(TERMIEN,.TERMARR)
- . D EVALPL^PXRMTERL(.FINDPA,.TERMARR,INDEX)
+ . D EVALPL^PXRMTERM(.FINDPA,.TERMARR,INDEX)
  . S DFN=0
  . F  S DFN=+$O(^TMP($J,INDEX,1,DFN)) Q:DFN=0  D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMOUTC.m	(revision 636)
@@ -1,8 +1,8 @@
-PXRMOUTC ; SLC/PKR - Clinical Maintenance output. ;07/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMOUTC ; SLC/PKR - Clinical Maintenance output. ;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;================================================
 CM(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL) ;Prepare the 
  ;clinical maintenance output.
- N IND,JND,FIDATA,FINDING,FLIST,FTYPE
+ N IND,FIDATA,FINDING,FLIST,FTYPE
  N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
  N TEMP,TEXT
@@ -37,11 +37,5 @@
  .. I '$D(FIDATA(FINDING)) Q
  .. K IFIEVAL
- .. ;I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
- .. ;E  S IFIEVAL=0
- .. I FIEVAL(FINDING) D
- ... M IFIEVAL=FIEVAL(FINDING)
- ...;Remove any false occurrences so they are not displayed.
- ... S JND=0
- ... F  S JND=+$O(IFIEVAL(JND)) Q:JND=0  K:'IFIEVAL(JND) IFIEVAL(JND)
+ .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
  .. E  S IFIEVAL=0
  ..;If the finding is false all we need to do is process the not found
@@ -88,5 +82,5 @@
  I FTYPE="PXRMD(811.4," D OUTPUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  I FTYPE="RAMIS(71," D OUTPUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
- I FTYPE="YTT(601.71," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="YTT(601," D OUTPUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMOUTM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;07/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMOUTM ; SLC/PKR - MyHealtheVet output. ;10/12/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;================================================
@@ -28,5 +28,5 @@
  I FTYPE="PXRMD(811.4," D MHVOUT^PXRMCF(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  I FTYPE="RAMIS(71," D MHVOUT^PXRMRAD(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
- I FTYPE="YTT(601.71," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
+ I FTYPE="YTT(601," D MHVOUT^PXRMMH(INDENT,.IFIEVAL,.NLINES,.TEXT) Q
  Q
  ;
@@ -49,5 +49,5 @@
 MHVD(DEFARR,PXRMPDEM,PCLOGIC,RESLOGIC,RESDATE,FIEVAL,WEB) ;Prepare the 
  ;MyHealtheVet detailed output.
- N IND,JND,FIDATA,FINDING,FLIST,FTYPE
+ N IND,FIDATA,FINDING,FLIST,FTYPE
  N HDR,NHDR,IFIEVAL,LIST,NFLINES,NTXT,NUM
  N TEXT
@@ -75,11 +75,5 @@
  .. I '$D(FIDATA(FINDING)) Q
  .. K IFIEVAL
- .. ;I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
- .. ;E  S IFIEVAL=0
- .. I FIEVAL(FINDING) D
- ... M IFIEVAL=FIEVAL(FINDING)
- ...;Remove any false occurrences so they are not displayed.
- ... S JND=0
- ... F  S JND=+$O(IFIEVAL(JND)) Q:JND=0  K:'IFIEVAL(JND) IFIEVAL(JND)
+ .. I FIEVAL(FINDING) M IFIEVAL=FIEVAL(FINDING)
  .. E  S IFIEVAL=0
  ..;Output the found/not found text for the finding.
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMP9E.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMP9E.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMP9E.m	(revision 636)
@@ -18,5 +18,5 @@
  D BM(" Code Set Update message fix (Remedy Ticket 175985)"),M(" ")
  N DA,DIC,DIQ,DR,PXRMB,PXRMBLD,PXRMBLDS,PXRMERR,PXRMHF,PXRMI,PXRML,PXRMPAT,PXRMPN,PXRMREQ,PXRMS,PXRMT,PXRMU,PXRMV,PXRMVER,X
- K XPDABORT,XPDQUIT S U="^",PXRMREQ="LEX*2.0*25;LEX*2.0*27;LEX*2.0*32;LEX*2.0*46;ICD*18.0*11;ICPT*6.0*16;PXRM*2.0*4"
+ K XPDABORT,XPDQUIT S U="^",PXRMREQ="LEX*2.0*25;LEX*2.0*27;ICD*18.0*11;ICPT*6.0*16;PXRM*2.0*4"
  S PXRMBLD="LEX*2.0*49",PXRMBLDS="LEX*2.0*49;ICD*18.0*28;ICPT*6.0*34;PXRM*2.0*9",PXRMHF="LEX_2_49.KID"
  K PXRMERR D:+($$UR)'>0 ET("User not defined (DUZ)") I $D(PXRMERR) D ABRT Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPARS.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMPARS ; SLC/PJH - Edit PXRM(800 reminder parameters. ;04/02/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPARS ; SLC/PJH - Edit PXRM(800 reminder parameters. ;06/14/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;called by protocol PXRM EDIT SITE DISCLAIMER
@@ -11,12 +11,4 @@
  D ^DIE
  D FORMAT^PXRMDISC
- Q
- ;
-MH(DA) ;Edit MH default Question Value
- Q:'$$LOCK(DA)
- N DIC,DIE,DR,Y
- ;Edit
- S DIE="^PXRM(800,",DR=17
- D ^DIE
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDR.m	(revision 636)
@@ -1,43 +1,48 @@
-PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;11/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPDR ;SLC/AGP,PKR - Patient List Demographic report main routine ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 EN(PLIEN) ; -- main entry point for PXRM PATIENT LIST DEMOGRAPHIC
- N ARRAY,DC,DDATA,DELIM,DTOUT,DUOUT
+ N ADDDATA,APPDATA,ARRAY,BACK,CNT,DC,DEMDATA,DELIM,DIC,DIR,DTOUT,DUOUT
+ N ELIGDATA,IEN,INPDATA
+ N FINDDATA,NAME,NODE,PFACDATA,PTIEN
+ N QUIT,REMDATA
+ N X,Y,YESNO
  W @IOF
  K ^TMP("PXRMPLD",$J),^TMP("PXRMPLN",$J)
- S DELIM=0
+ S BACK=0,DELIM=0,QUIT=0
 OPTION ;
  W !,"Select the items to include on the report."
-ADDSEL D ADDSEL^PXRMPDRS(.DDATA,"ADD")
+ADDSEL D ADDSEL^PXRMPDRS(.ADDDATA)
  I $D(DTOUT)!$D(DUOUT) Q
-APPSEL D APPSEL^PXRMPDRS(.DDATA,"APP")
+APPSEL D APPSEL^PXRMPDRS(.APPDATA)
  I $D(DTOUT)!$D(DUOUT) G ADDSEL
-DEMSEL D DEMSEL^PXRMPDRS(.DDATA,"DEM")
+DEMSEL D DEMSEL^PXRMPDRS(.DEMDATA)
  I $D(DTOUT)!$D(DUOUT) G APPSEL
-PFACSEL S DDATA("PFAC",0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
+PFACSEL S PFACDATA(0)=$$ASKYN^PXRMEUT("N","Include the patient's preferred facility")
  I $D(DTOUT)!$D(DUOUT) G DEMSEL
- S DDATA("PFAC","LEN")=$S(DDATA("PFAC",0)=1:1,1:0)
-ELIGSEL D ELIGSEL^PXRMPDRS(.DDATA,"ELIG")
+ S PFACDATA("LEN")=$S(PFACDATA(0)=1:1,1:0)
+ELIGSEL D ELIGSEL^PXRMPDRS(.ELIGDATA)
  I $D(DTOUT)!$D(DUOUT) G PFACSEL
-DATASEL D DATASEL^PXRMPDRS(PLIEN,.DDATA,"FIND")
+DATASEL D DATASEL^PXRMPDRS(PLIEN,.FINDDATA)
  I $D(DTOUT)!$D(DUOUT) G ELIGSEL
-INPSEL D INPSEL^PXRMPDRS(.DDATA,"INP")
+INPSEL D INPSEL^PXRMPDRS(.INPDATA)
  I $D(DTOUT)!$D(DUOUT) G DATASEL
-REMDATA D REMSEL^PXRMPDRS(PLIEN,.DDATA,"REM")
+REMDATA D REMSEL^PXRMPDRS(PLIEN,.REMDATA)
  I $D(DTOUT)!$D(DUOUT) G INPSEL
  S DELIM=$$ASKYN^PXRMEUT("Y","Delimited Report:")
  I $D(DTOUT)!$D(DUOUT) G REMDATA
- S DC=$S(DELIM:$$DELIMSEL^PXRMXSD,1:U)
+ I DELIM S DC=$$DELIMSEL^PXRMXSD
  I $D(DTOUT)!$D(DUOUT) G OPTION
 DEVICE ;
- N DESC,DIR,PXRMQUE,RTN,SAVE,%ZIS
+ N DIR,PXRMQUE,%ZIS,ZTDESC,ZTRTN,ZTSAVE
  S %ZIS="M"
- S DESC="Patient List Demographic Report"
- S RTN="GETPDATA^PXRMPDR(DELIM,DC,PLIEN,.DDATA)"
- S SAVE("DELIM")="",SAVE("DC")="",SAVE("PLIEN")=""
- S SAVE("DDATA(")=""
- S PXRMQUE=$$DEVICE^PXRMXQUE(RTN,DESC,.SAVE,.%ZIS,1)
- I PXRMQUE'="" G EXIT
+ S ZTDESC="Patient List Demographic"
+ S ZTRTN="GETDATA^PXRMPDR(DELIM,PLIEN,.DEMDATA,.PFACDATA,.ADDDATA,.INPDATA,.APPDATA,.FINDDATA,.REMDATA)"
+ S ZTSAVE("*")=""
+ S PXRMQUE=0
+ S PXRMQUE=$$DEVICE^PXRMXQUE(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I PXRMQUE=1 G EXIT
  I $D(DTOUT)!$D(DUOUT) G EXIT
+ ;
  S DIR(0)="E" D ^DIR
 EXIT D KVA^VADPT
@@ -45,5 +50,5 @@
  Q
  ;
-GETPDATA(DELIM,DC,PLIEN,DDATA) ;
+GETDATA(DELIM,PLIEN,DEMDATA,PFACDATA,ADDDATA,INPDATA,APPDATA,FINDDATA,REMDATA) ;
  N DATA,DATE,DCREAT,DFN,DTYPE,ERRMSG
  N GETADD,GETAPP,GETDEM,GETELIG,GETFIND,GETINP,GETREM
@@ -54,11 +59,11 @@
  S LISTNAME=$P(^PXRMXP(810.5,PLIEN,0),U,1)
  S DCREAT=$P(^PXRMXP(810.5,PLIEN,0),U,4)
- S GETDEM=$S(DDATA("DEM","LEN")>0:1,1:0)
- S GETADD=$S(DDATA("ADD","LEN")>0:1,1:0)
- S GETINP=$S(DDATA("INP","LEN")>0:1,1:0)
- S GETELIG=$S(DDATA("ELIG","LEN")>0:1,1:0)
- S GETAPP=$S(DDATA("APP","LEN")>0:1,1:0)
- S GETFIND=$S(DDATA("FIND","LEN")>0:1,1:0)
- S GETREM=$S(DDATA("REM","LEN")>0:1,1:0)
+ S GETDEM=$S(DEMDATA("LEN")>0:1,1:0)
+ S GETADD=$S(ADDDATA("LEN")>0:1,1:0)
+ S GETINP=$S(INPDATA("LEN")>0:1,1:0)
+ S GETELIG=$S(ELIGDATA("LEN")>0:1,1:0)
+ S GETAPP=$S(APPDATA("LEN")>0:1,1:0)
+ S GETFIND=$S(FINDDATA("LEN")>0:1,1:0)
+ S GETREM=$S(REMDATA("LEN")>0:1,1:0)
  S IEN=0
  F  S IEN=+$O(^PXRMXP(810.5,PLIEN,30,IEN)) Q:IEN=0  D
@@ -72,9 +77,9 @@
  .. N VADM
  .. D DEM^VADPT
- .. F IND=1:1:DDATA("DEM","LEN") D
- ... S JND=$P(DDATA("DEM"),",",IND)
- ... S KND=0
- ... F  S KND=$O(DDATA("DEM",JND,KND)) Q:KND=""  D
- .... S PIECE=$P(DDATA("DEM",JND,KND),U,2)
+ .. F IND=1:1:DEMDATA("LEN") D
+ ... S JND=$P(DEMDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(DEMDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(DEMDATA(JND,KND),U,2)
  .... S TDATA=$P(VADM(KND),U,PIECE)
  .... S LND=""
@@ -82,63 +87,63 @@
  ..... I TDATA'="" S TDATA=TDATA_"~"
  ..... S TDATA=TDATA_$P(VADM(KND,LND),U,PIECE)
- .... I KND=2,'DDATA("DEM","FULLSSN") S TDATA=$E(TDATA,8,11)
- .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEM")=PDATA,PDATA=""
- . I DDATA("PFAC",0)=1 D
+ .... I KND=2,'DEMDATA("FULLSSN") S TDATA=$E(TDATA,8,11)
+ .... S $P(PDATA,U,KND)=TDATA
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"DEMDATA")=PDATA,PDATA=""
+ . I PFACDATA(0)=1 D
  ..;DBIA #1850
  .. S TDATA=$$GET1^DIQ(2,DFN,27.02,"E","","ERRMSG")
  .. I TDATA="" S TDATA="NONE"
- .. S ^TMP("PXRMPLD",$J,DFN,"PFAC")=TDATA
+ .. S ^TMP("PXRMPLD",$J,DFN,"PFACDATA")=TDATA
  . I GETADD D
  .. N VAPA
  .. D ADD^VADPT
- .. F IND=1:1:DDATA("ADD","LEN") D
- ... S JND=$P(DDATA("ADD"),",",IND)
- ... S KND=0
- ... F  S KND=$O(DDATA("ADD",JND,KND)) Q:KND=""  D
- .... S PIECE=$P(DDATA("ADD",JND,KND),U,2)
+ .. F IND=1:1:ADDDATA("LEN") D
+ ... S JND=$P(ADDDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(ADDDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(ADDDATA(JND,KND),U,2)
  .... S TDATA=$P(VAPA(KND),U,PIECE)
  .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADD")=PDATA,PDATA=""
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ADDDATA")=PDATA,PDATA=""
  . I GETINP D
  .. N VAIP
  .. D INP^VADPT
- .. F IND=1:1:DDATA("INP","LEN") D
- ... S JND=$P(DDATA("INP"),",",IND)
- ... S KND=0
- ... F  S KND=$O(DDATA("INP",JND,KND)) Q:KND=""  D
- .... S PIECE=$P(DDATA("INP",JND,KND),U,2)
+ .. F IND=1:1:INPDATA("LEN") D
+ ... S JND=$P(INPDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(INPDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(INPDATA(JND,KND),U,2)
  .... S TDATA=$P(VAIN(KND),U,PIECE)
  .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INP")=PDATA,PDATA=""
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"INPDATA")=PDATA,PDATA=""
  . I GETELIG D
  .. N VAEL
  .. D ELIG^VADPT
- .. F IND=1:1:DDATA("ELIG","LEN") D
- ... S JND=$P(DDATA("ELIG"),",",IND)
- ... S KND=0
- ... F  S KND=$O(DDATA("ELIG",JND,KND)) Q:KND=""  D
- .... S PIECE=$P(DDATA("ELIG",JND,KND),U,2)
+ .. F IND=1:1:ELIGDATA("LEN") D
+ ... S JND=$P(ELIGDATA,",",IND)
+ ... S KND=0
+ ... F  S KND=$O(ELIGDATA(JND,KND)) Q:KND=""  D
+ .... S PIECE=$P(ELIGDATA(JND,KND),U,2)
  .... S TDATA=$P(VAEL(KND),U,PIECE)
  .... I KND=4 S TDATA=$S(TDATA=1:"YES",1:"NO")
  .... S $P(PDATA,U,KND)=TDATA
- .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIG")=PDATA,PDATA=""
+ .. I PDATA'="" S ^TMP("PXRMPLD",$J,DFN,"ELIGDATA")=PDATA,PDATA=""
  . D KVA^VADPT
  . I GETREM D
  .. S IND=0
- .. F  S IND=$O(DDATA("REM","IEN",IND)) Q:IND=""  D
+ .. F  S IND=$O(REMDATA("IEN",IND)) Q:IND=""  D
  ... S PDATA=$G(^PXRMXP(810.5,PLIEN,30,IEN,"REM",IND,0))
  ... I PDATA="" Q
  ... S RIEN=$P(PDATA,U,1)
- ... S ^TMP("PXRMPLD",$J,DFN,"REM",RIEN)=PDATA,PDATA=""
+ ... S ^TMP("PXRMPLD",$J,DFN,"REMDATA",RIEN)=PDATA,PDATA=""
  . I GETFIND D
  .. N DL
- .. F IND=1:1:DDATA("FIND","LEN") D
- ... S JND=$P(DDATA("FIND"),",",IND)
- ... S DTYPE=DDATA("FIND",JND,JND)
+ .. F IND=1:1:FINDDATA("LEN") D
+ ... S JND=$P(FINDDATA,",",IND)
+ ... S DTYPE=FINDDATA(JND,JND)
  ... S KND=$O(^PXRMXP(810.5,PLIEN,30,IEN,"DATA","B",DTYPE,""))
  ... S DL=$S(KND="":0,1:$L(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U))
  ... S DATA=$S(KND="":"",1:$P(^PXRMXP(810.5,PLIEN,30,IEN,"DATA",KND,0),U,2,DL))
- ... S ^TMP("PXRMPLD",$J,DFN,"FIND",JND)=DATA
+ ... S ^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND)=DATA
  ;Get appointment data for all patients on the list.
  I GETAPP D
@@ -146,8 +151,8 @@
  . S ARRAY(1)=DT,ARRAY(3)="I;R"
  . S ARRAY(4)="^TMP($J,""PXRMPL""",ARRAY("FLDS")=""
- . F IND=1:1:DDATA("APP","LEN") D
- .. S JND=$P(DDATA("APP"),",",IND)
+ . F IND=1:1:APPDATA("LEN") D
+ .. S JND=$P(APPDATA,",",IND)
  .. S KND=0
- .. F  S KND=$O(DDATA("APP",JND,KND)) Q:KND=""  S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
+ .. F  S KND=$O(APPDATA(JND,KND)) Q:KND=""  S ARRAY("FLDS")=ARRAY("FLDS")_KND_";"
  . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  . S IND=0
@@ -158,5 +163,5 @@
  . I COUNT=-1 D  Q
  .. D APPERR^PXRMPDRS
- .. S DDATA("APP","ERROR")=""
+ .. S APPDATA("ERROR")=""
  .. K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
  . F IND=1:1:COUNT D
@@ -172,8 +177,8 @@
  ..... S TDATA=$P(TDATA,U,2),TDATA=$P(TDATA,";",2)
  ..... S PDATA=PDATA_U_TDATA
- ..... S ^TMP("PXRMPLD",$J,DFN,"APP",KND)=PDATA
+ ..... S ^TMP("PXRMPLD",$J,DFN,"APPDATA",KND)=PDATA
  . K ^TMP($J,"PXRMPL"),^TMP($J,"SDAMA301")
- I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.DDATA)
- I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.DDATA)
+ I DELIM=1 D DELIMPR^PXRMPDRP(DC,PLIEN,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
+ I DELIM=0 D REGPR^PXRMPDRP(PLIEN,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
  Q
  ;
@@ -184,5 +189,5 @@
  ;
 PAGE ;
- I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  .S DIR(0)="E"
  .W !
@@ -191,5 +196,5 @@
  W:$D(IOF) @IOF
  S PAGE=PAGE+1
- I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
- Q
- ;
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ Q
+ ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDRP.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMPDRP ;SLC/AGP,PKR - Patient List Demographic report print routine ;11/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPDRP ;SLC/AGP,PKR - Patient List Demographic report print routine ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 ADDTXT(TEXT) ;Accumulate text in ^TMP.
@@ -7,34 +7,34 @@
  Q
  ;
-APPHDR(DC,DDATA,SUB) ;Build the appointment header.
- I DDATA(SUB,"LEN")'>0 Q
+APPHDR(DC,APPDATA) ;Build the appointment header.
+ I APPDATA("LEN")'>0 Q
  N HDR,IND,JND,KND,LND,TEMP
  S IND=0,HDR=""
- F IND=1:1:DDATA(SUB,"MAX") D
- . F JND=1:1:DDATA(SUB,"LEN") D
- .. S KND=$P(DDATA(SUB),",",JND)
+ F IND=1:1:APPDATA("MAX") D
+ . F JND=1:1:APPDATA("LEN") D
+ .. S KND=$P(APPDATA,",",JND)
  .. S LND=""
- .. F  S LND=$O(DDATA(SUB,KND,LND)) Q:LND=""  D
- ... S TEMP=$P(DDATA(SUB,KND,LND),U,1)
+ .. F  S LND=$O(APPDATA(KND,LND)) Q:LND=""  D
+ ... S TEMP=$P(APPDATA(KND,LND),U,1)
  ... S HDR=HDR_TEMP_IND_DC
- S DDATA(SUB,"HDR")=HDR
- Q
- ;
-APPPRINT(DFN,DDATA,SUB) ;Print appointment data.
+ S APPDATA("HDR")=HDR
+ Q
+ ;
+APPPRINT(DFN,APPDATA) ;Print appointment data.
  N CLINIC,COUNT,DATE,HDR,IND,JND,KND,LINE,PCLINIC,PDATE,TEMP
  S (PCLINIC,PDATE)=0
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:APPDATA("LEN") D
+ . S JND=$P(APPDATA,",",IND)
  . I JND=1 S PDATE=1
  . I JND=2 S PCLINIC=1
  S HDR=""
- I PDATE S HDR=" "_$P(DDATA(SUB,1,1),U,1)
- I PCLINIC S HDR=HDR_"   "_$P(DDATA(SUB,2,2),U,1)
+ I PDATE S HDR=" "_$P(APPDATA(1,1),U,1)
+ I PCLINIC S HDR=HDR_"   "_$P(APPDATA(2,2),U,1)
  D ADDTXT(" ")
  D ADDTXT("Appointment Data")
  D ADDTXT(HDR)
  S COUNT=0
- F  S COUNT=$O(^TMP("PXRMPLD",$J,DFN,"APP",COUNT)) Q:COUNT=""  D
- . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APP",COUNT))
+ F  S COUNT=$O(^TMP("PXRMPLD",$J,DFN,"APPDATA",COUNT)) Q:COUNT=""  D
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APPDATA",COUNT))
  . S LINE=""
  . I PDATE S LINE=LINE_$P(TEMP,U,1)
@@ -43,44 +43,43 @@
  Q
  ;
-DELIMHDR(DC,DDATA,SUB) ;Build the delimited header for a data type.
- I DDATA(SUB,"LEN")'>0 Q
+DELIMHDR(DC,DATA) ;Build the delimited header for a data type.
+ I DATA("LEN")'>0 Q
  N HDR,IND,JND,KND,LND,MAX,TEMP
  S IND=0,HDR=""
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
  . S KND=""
- . F  S KND=$O(DDATA(SUB,JND,KND)) Q:KND=""  D
- .. S TEMP=$P(DDATA(SUB,JND,KND),U,1)
- .. S MAX=$P(DDATA(SUB,JND,KND),U,3)
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S TEMP=$P(DATA(JND,KND),U,1)
+ .. S MAX=$P(DATA(JND,KND),U,3)
  .. I MAX="" S HDR=HDR_TEMP_DC
  .. I +MAX>0 F LND=1:1:MAX S HDR=HDR_TEMP_LND_DC
- S DDATA(SUB,"HDR")=HDR
- Q
- ;
-DELIMPR(DC,PLIEN,DDATA) ;
+ S DATA("HDR")=HDR
+ Q
+ ;
+DELIMPR(DC,PLIEN,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;
  ;Print the delimited report.
  N DATALIST,DFN,IND,NDT,PNAME
  S NDT=0
- I DDATA("ADD","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ADD"
- I DDATA("APP","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="APP"
- I DDATA("DEM","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="DEM"
- I DDATA("ELIG","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ELIG"
- I DDATA("FIND","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="FIND"
- I DDATA("INP","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="INP"
- I DDATA("PFAC","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="PFAC"
- I DDATA("REM","LEN")>0 S NDT=NDT+1,DATALIST(NDT)="REM"
- S DATALIST(0)=NDT
+ I ADDDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ADDDATA"
+ I APPDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="APPDATA"
+ I DEMDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="DEMDATA"
+ I ELIGDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="ELIGDATA"
+ I FINDDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="FINDDATA"
+ I INPDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="INPDATA"
+ I PFACDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="PFACDATA"
+ I REMDATA("LEN")>0 S NDT=NDT+1,DATALIST(NDT)="REMDATA"
  D TITLE(PLIEN,1)
- ;Create the delimited header.
+ ;Output the delimited header.
  F IND=1:1:NDT D
- . I DATALIST(IND)="ADD" D DELIMHDR(DC,.DDATA,"ADD") Q
- . I DATALIST(IND)="APP" D APPHDR(DC,.DDATA,"APP") Q
- . I DATALIST(IND)="DEM" D DELIMHDR(DC,.DDATA,"DEM") Q
- . I DATALIST(IND)="ELIG" D DELIMHDR(DC,.DDATA,"ELIG") Q
- . I DATALIST(IND)="FIND" D DELIMHDR(DC,.DDATA,"FIND") Q
- . I DATALIST(IND)="INP" D DELIMHDR(DC,.DDATA,"INP") Q
- . I DATALIST(IND)="PFAC" D PFACHDR(.DDATA,"PFAC")
- . I DATALIST(IND)="REM" D REMHDR(DC,.DDATA,"REM") Q
- D DELTITLE(DC,.DATALIST,.DDATA)
+ . I DATALIST(IND)="ADDDATA" D DELIMHDR(DC,.ADDDATA) Q
+ . I DATALIST(IND)="APPDATA" D APPHDR(DC,.APPDATA) Q
+ . I DATALIST(IND)="DEMDATA" D DELIMHDR(DC,.DEMDATA) Q
+ . I DATALIST(IND)="ELIGDATA" D DELIMHDR(DC,.ELIGDATA) Q
+ . I DATALIST(IND)="FINDDATA" D DELIMHDR(DC,.FINDDATA) Q
+ . I DATALIST(IND)="INPDATA" D DELIMHDR(DC,.INPDATA) Q
+ . I DATALIST(IND)="PFACDATA" D PFACHDR(.PFACDATA)
+ . I DATALIST(IND)="REMDATA" D REMHDR(DC,.REMDATA) Q
+ D DELTITLE(DC,.ADDDATA,.APPDATA,.DEMDATA,.FINDDATA,.INPDATA,.PFACDATA,.REMDATA)
  S PNAME=":"
  F  S PNAME=$O(^TMP("PXRMPLN",$J,PNAME)) Q:PNAME=""  D
@@ -89,32 +88,39 @@
  .. W !,PNAME_DC
  .. F IND=1:1:NDT D
- ... I DATALIST(IND)="ADD" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"ADD") Q
- ... I DATALIST(IND)="APP" D PAPPDATA(DFN,DC,.DDATA,"APP") Q
- ... I DATALIST(IND)="DEM" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"DEM") Q
- ... I DATALIST(IND)="ELIG" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"ELIG") Q
- ... I DATALIST(IND)="FIND" D PFINDATA(DFN,DC,.DDATA,"FIND") Q
- ... I DATALIST(IND)="INP" D PDELDATA(DFN,DC,DATALIST(IND),.DDATA,"INP") Q
- ... I DATALIST(IND)="PFAC" D PFACDATA(DFN,.DDATA,"PFAC") Q
- ... I DATALIST(IND)="REM" D PREMDATA(DFN,DC,.DDATA,"REM") Q
+ ... I DATALIST(IND)="ADDDATA" D PDELDATA(DFN,DC,DATALIST(IND),.ADDDATA) Q
+ ... I DATALIST(IND)="APPDATA" D PAPPDATA(DFN,DC,.APPDATA) Q
+ ... I DATALIST(IND)="DEMDATA" D PDELDATA(DFN,DC,DATALIST(IND),.DEMDATA) Q
+ ... I DATALIST(IND)="ELIGDATA" D PDELDATA(DFN,DC,DATALIST(IND),.ELIGDATA) Q
+ ... I DATALIST(IND)="FINDDATA" D PFINDATA(DFN,DC,.FINDDATA) Q
+ ... I DATALIST(IND)="INPDATA" D PDELDATA(DFN,DC,DATALIST(IND),.INPDATA) Q
+ ... I DATALIST(IND)="PFACDATA" D PFACDATA(DFN,.PFACDATA) Q
+ ... I DATALIST(IND)="REMDATA" D PREMDATA(DFN,DC,.REMDATA) Q
  .. W "\\"
  Q
  ;
-DELTITLE(DC,DATALIST,DDATA) ;Combine all the headers to create the delimited title.
+DELTITLE(DC,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;Combine
+ ;all the headers to create the delimited title.
  W !,"PATIENT"_DC
- N IND
- F IND=1:1:DATALIST(0) W DDATA(DATALIST(IND),"HDR")
+ W $G(ADDDATA("HDR"))
+ W $G(APPDATA("HDR"))
+ W $G(DEMDATA("HDR"))
+ W $G(ELIGDATA("HDR"))
+ W $G(FINDDATA("HDR"))
+ W $G(INPDATA("HDR"))
+ W $G(PFACDATA("HDR"))
+ W $G(REMDATA("HDR"))
  W "\\"
  Q
  ;
-FINDPR(DFN,DDATA,SUB) ;Print finding information.
+FINDPR(DFN,FINDDATA) ;Print finding information.
  N IND,JND,LINE,TEMP
  D ADDTXT(" ")
  S LINE="Finding Data"
  D ADDTXT(LINE)
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
- . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FIND",JND))
+ F IND=1:1:FINDDATA("LEN") D
+ . S JND=$P(FINDDATA,",",IND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND))
  . I TEMP="" Q
- . S LINE=" "_$P(DDATA(SUB,JND,JND),U,1)_": "_TEMP
+ . S LINE=" "_$P(FINDDATA(JND,JND),U,1)_": "_TEMP
  . D ADDTXT(LINE)
  Q
@@ -134,5 +140,5 @@
  ;
 PAGE ;
- I ($E(IOST,1,2)="C-")&(IO=IO(0)) D
+ I ($E(IOST)="C")&(IO=IO(0)) D
  . N DIR
  . S DIR(0)="E"
@@ -141,31 +147,32 @@
  I $D(DUOUT)!$D(DTOUT) Q
  W:$D(IOF) @IOF
- I ($E(IOST,1,2)="C-")&(IO=IO(0)) W @IOF
- Q
- ;
-PAPPDATA(DFN,DC,DDATA,SUB) ;Print the delimited appointment data.
+ I $E(IOST)="C",IO=IO(0) W @IOF
+ Q
+ ;
+PAPPDATA(DFN,DC,APPDATA) ;Print the delimited appointment data.
  N IND,JND,KND,LINE,LND,PIECE,TEMP
- I DDATA(SUB,"LEN")'>0 Q
+ I APPDATA("LEN")'>0 Q
  S LINE=""
- F IND=1:1:DDATA(SUB,"MAX") D
- . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APP",IND))
- . F JND=1:1:DDATA(SUB,"LEN") D
- .. S KND=$P(DDATA(SUB),",",JND)
+ F IND=1:1:APPDATA("MAX") D
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"APPDATA",IND))
+ . F JND=1:1:APPDATA("LEN") D
+ .. S KND=$P(APPDATA,",",JND)
  .. S LND=""
- .. F  S LND=$O(DDATA(SUB,KND,LND)) Q:LND=""  D
- ... S PIECE=$P(DDATA(SUB,KND,KND),U,2)
+ .. F  S LND=$O(APPDATA(KND,LND)) Q:LND=""  D
+ ... S PIECE=$P(APPDATA(KND,KND),U,2)
  ... S LINE=LINE_$P(TEMP,U,PIECE)_DC
  W LINE
  Q
  ;
-PDELDATA(DFN,DC,DTYPE,DDATA,SUB) ;Print the delimited data.
+PDELDATA(DFN,DC,DTYPE,DATA) ;Print the delimited data.
  N IND,JND,KND,LINE,LND,TEMP,TTEMP
+ I DATA("LEN")'>0 Q
  S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
  S LINE=""
- F IND=1:1:DDATA(DTYPE,"LEN") D
- . S JND=$P(DDATA(DTYPE),",",IND)
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
  . S KND=""
- . F  S KND=$O(DDATA(DTYPE,JND,KND)) Q:KND=""  D
- .. S MAX=$P(DDATA(DTYPE,JND,KND),U,3)
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
+ .. S MAX=$P(DATA(JND,KND),U,3)
  .. I MAX="" S LINE=LINE_$P(TEMP,U,KND)_DC Q
  .. I +MAX>1 S TTEMP=$P(TEMP,U,KND) F LND=1:1:MAX S LINE=LINE_$P(TTEMP,"~",LND)_DC
@@ -173,43 +180,43 @@
  Q
  ;
-PFACHDR(DDATA,SUB) ;Build the preferred facility header.
- I DDATA(SUB,0)=1 S DDATA(SUB,"HDR")="PATIENT'S PREFERRED FACILITY"
- Q
- ;
-PFACDATA(DFN,DDATA,SUB) ;Print the patient's preferred facility data, delimited.
- I DDATA(SUB,0)=0 Q
- W ^TMP("PXRMPLD",$J,DFN,"PFAC")
- Q
- ;
-PFACPR(DFN,DDATA,SUB) ;Print the patient's preferred facility.
- I DDATA(SUB,0)=0 Q
+PFACHDR(PFACDATA) ;Build the preferred facility header.
+ I PFACDATA(0)=1 S PFACDATA("HDR")="PATIENT'S PREFERRED FACILITY"
+ Q
+ ;
+PFACDATA(DFN,PFACDATA) ;Print the patient's preferred facility data, delimited.
+ I PFACDATA(0)=0 Q
+ W ^TMP("PXRMPLD",$J,DFN,"PFACDATA")
+ Q
+ ;
+PFACPR(DFN,PFACDATA) ;Print the patient's preferred facility.
+ I PFACDATA(0)=0 Q
  D ADDTXT("Patient's Preferred Facility")
- D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFAC")))
- Q
- ;
-PFINDATA(DFN,DC,DDATA,SUB) ;Print the finding data.
+ D ADDTXT(" "_$G(^TMP("PXRMPLD",$J,DFN,"PFACDATA")))
+ Q
+ ;
+PFINDATA(DFN,DC,FINDDATA) ;Print the finding data.
  N IND,JND,LINE,TEMP
- I DDATA(SUB,"LEN")'>0 Q
+ I FINDDATA("LEN")'>0 Q
  S LINE=""
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
- . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FIND",JND))
+ F IND=1:1:FINDDATA("LEN") D
+ . S JND=$P(FINDDATA,",",IND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"FINDDATA",JND))
  . S LINE=LINE_TEMP_DC
  W LINE
  Q
  ;
-PREMDATA(DFN,DC,DDATA,SUB) ;Print the reminder data.
+PREMDATA(DFN,DC,REMDATA) ;Print the reminder data.
  N IND,JND,LINE,TEMP
- I DDATA(SUB,"LEN")'>0 Q
+ I REMDATA("LEN")'>0 Q
  S LINE=""
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
- . S LINE=LINE_DDATA(SUB,"RNAME",JND)_DC
- . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REM",DDATA(SUB,"IEN",JND)))
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S LINE=LINE_REMDATA("RNAME",JND)_DC
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REMDATA",REMDATA("IEN",JND)))
  . S LINE=LINE_$P(TEMP,U,2)_DC_$P(TEMP,U,3)_"^"_$P(TEMP,U,4)_DC
  W LINE
  Q
  ;
-REGPR(PLIEN,DDATA,SUB) ;
+REGPR(PLIEN,ADDDATA,APPDATA,DEMDATA,FINDDATA,INPDATA,PFACDATA,REMDATA) ;
  ;Print the regular report..
  N DATATYPE,DFN,PNAME,LINCNT
@@ -225,40 +232,40 @@
  .. S DATATYPE=""
  .. F  S DATATYPE=$O(^TMP("PXRMPLD",$J,DFN,DATATYPE)) Q:DATATYPE=""  D
- ... I DATATYPE="ADD" D VADPTPR(DFN,"Address Data",DATATYPE,.DDATA,"ADD") Q
- ... I DATATYPE="APP" D APPPRINT(DFN,.DDATA,"APP") Q
- ... I DATATYPE="DEM" D VADPTPR(DFN,"Demographic Data",DATATYPE,.DDATA,"DEM") Q
- ... I DATATYPE="ELIG" D VADPTPR(DFN,"Eligibility Data",DATATYPE,.DDATA,"ELIG") Q
- ... I DATATYPE="FIND" D FINDPR(DFN,.DDATA,"FIND") Q
- ... I DATATYPE="INP" D VADPTPR(DFN,"Inpatient Data",DATATYPE,.DDATA,"INP") Q
- ... I DATATYPE="PFAC" D PFACPR(DFN,.DDATA,"PFAC") Q
- ... I DATATYPE="REM" D REMPR(DFN,.DDATA,"REM") Q
+ ... I DATATYPE="ADDDATA" D VADPTPR(DFN,"Address Data",DATATYPE,.ADDDATA) Q
+ ... I DATATYPE="APPDATA" D APPPRINT(DFN,.APPDATA) Q
+ ... I DATATYPE="DEMDATA" D VADPTPR(DFN,"Demographic Data",DATATYPE,.DEMDATA) Q
+ ... I DATATYPE="ELIGDATA" D VADPTPR(DFN,"Eligibility Data",DATATYPE,.ELIGDATA) Q
+ ... I DATATYPE="FINDDATA" D FINDPR(DFN,.FINDDATA) Q
+ ... I DATATYPE="INPDATA" D VADPTPR(DFN,"Inpatient Data",DATATYPE,.INPDATA) Q
+ ... I DATATYPE="PFACDATA" D PFACPR(DFN,.PFACDATA) Q
+ ... I DATATYPE="REMDATA" D REMPR(DFN,.REMDATA) Q
  D OUTPUT
  K ^TMP("PXRMPDEM",$J)
  Q
  ;
-REMHDR(DC,DDATA,SUB) ;Build the reminder data delimited header.
+REMHDR(DC,REMDATA) ;Build the reminder data delimited header.
  N HDR,IND,JND
  S HDR=""
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
  . S HDR=HDR_"REMINDER"_JND_DC_"STATUS"_JND_DC_"DUE DATE"_JND_DC_"LAST DONE"_JND_DC
- S DDATA(SUB,"HDR")=HDR
- Q
- ;
-REMPR(DFN,DDATA,SUB) ;Print reminder status information.
+ S REMDATA("HDR")=HDR
+ Q
+ ;
+REMPR(DFN,REMDATA) ;Print reminder status information.
  N DUE,IND,JND,LAST,LINE,NSP,STATUS,TEMP
  D ADDTXT(" ")
  S LINE="Reminder:"_$$INSCHR^PXRMEXLC(27," ")_"--STATUS--  --DUE DATE--  --LAST DONE--"
  D ADDTXT(LINE)
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
- . S RIEN=DDATA(SUB,"IEN",JND)
- . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REM",RIEN))
+ F IND=1:1:REMDATA("LEN") D
+ . S JND=$P(REMDATA,",",IND)
+ . S RIEN=REMDATA("IEN",JND)
+ . S TEMP=$G(^TMP("PXRMPLD",$J,DFN,"REMDATA",RIEN))
  . I TEMP="" Q
  . S STATUS=$P(TEMP,U,2)
  . S DUE=$P(TEMP,U,3),DUE=$$EDATE^PXRMDATE(DUE)
  . S LAST=$P(TEMP,U,4),LAST=$$EDATE^PXRMDATE(LAST)
- . S NSP=38-$L(DDATA(SUB,"RNAME",JND))
- . S LINE=DDATA(SUB,"RNAME",JND)_$$INSCHR^PXRMEXLC(NSP," ")_STATUS
+ . S NSP=38-$L(REMDATA("RNAME",JND))
+ . S LINE=REMDATA("RNAME",JND)_$$INSCHR^PXRMEXLC(NSP," ")_STATUS
  . S NSP=54-$L(LINE)-($L(DUE)/2)
  . S LINE=LINE_$$INSCHR^PXRMEXLC(NSP," ")_DUE
@@ -282,18 +289,18 @@
  Q
  ;
-VADPTPR(DFN,DNAME,DTYPE,DDATA,SUB) ;Print data returned by a VADPT call.
+VADPTPR(DFN,DNAME,DTYPE,DATA) ;Print data returned by a VADPT call.
  N IND,JND,KND,LINE,LND,MAX,TEMP,TTEMP
  D ADDTXT(" ")
  D ADDTXT(DNAME)
  S TEMP=$G(^TMP("PXRMPLD",$J,DFN,DTYPE))
- F IND=1:1:DDATA(SUB,"LEN") D
- . S JND=$P(DDATA(SUB),",",IND)
+ F IND=1:1:DATA("LEN") D
+ . S JND=$P(DATA,",",IND)
  . S KND=""
- . F  S KND=$O(DDATA(SUB,JND,KND)) Q:KND=""  D
+ . F  S KND=$O(DATA(JND,KND)) Q:KND=""  D
  .. S TTEMP=$P(TEMP,U,KND)
- .. S MAX=+$P(DDATA(SUB,JND,KND),U,3)
+ .. S MAX=+$P(DATA(JND,KND),U,3)
  .. I MAX=0 S MAX=1
  .. F LND=1:1:MAX D
- ... S LINE=" "_$P(DDATA(SUB,JND,KND),U,1)_": "_$P(TTEMP,"~",LND)
+ ... S LINE=" "_$P(DATA(JND,KND),U,1)_": "_$P(TTEMP,"~",LND)
  ... D ADDTXT(LINE)
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPDRS.m	(revision 636)
@@ -1,12 +1,12 @@
-PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;03/22/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPDRS ;SLC/PKR - Patient List Demographic Report data selection. ;07/18/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
-ADDSEL(DATA,SUB) ;Let the user select the address information they want.
+ADDSEL(ADDDATA) ;Let the user select the address information they want.
  N ADDLIST,LIST
- S ADDLIST("A",1)=" 1 - CURRENT ADDRESS",DATA(SUB,1,1)="STREET ADDRESS #1"_U_1
- S DATA(SUB,1,2)="STREET ADDRESS #2"_U_1,DATA(SUB,1,3)="STREET ADDRESS #3"_U_1
- S DATA(SUB,1,4)="CITY"_U_1,DATA(SUB,1,5)="STATE"_U_2,DATA(SUB,1,6)="ZIP"_U_1
- S DATA(SUB,1,7)="COUNTY"_U_2
- S ADDLIST("A",2)=" 2 - PHONE NUMBER",DATA(SUB,2,8)="PHONE NUMBER"_U_1
+ S ADDLIST("A",1)=" 1 - CURRENT ADDRESS",ADDDATA(1,1)="STREET ADDRESS #1"_U_1
+ S ADDDATA(1,2)="STREET ADDRESS #2"_U_1,ADDDATA(1,3)="STREET ADDRESS #3"_U_1
+ S ADDDATA(1,4)="CITY"_U_1,ADDDATA(1,5)="STATE"_U_2,ADDDATA(1,6)="ZIP"_U_1
+ S ADDDATA(1,7)="COUNTY"_U_2
+ S ADDLIST("A",2)=" 2 - PHONE NUMBER",ADDDATA(2,8)="PHONE NUMBER"_U_1
  S ADDLIST("A")="Enter your selection(s)"
  S ADDLIST("?")="^D HELP^PXRMPDRS"
@@ -14,6 +14,6 @@
  S LIST=$$SEL^PXRMPDRS(.ADDLIST,2)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S ADDDATA=LIST
+ S ADDDATA("LEN")=$L(LIST,",")-1
  Q
  ;
@@ -44,5 +44,5 @@
  Q
  ;
-APPSEL(DATA,SUB) ;Let the user select the appointment information they want.
+APPSEL(APPDATA) ;Let the user select the appointment information they want.
  ;The first subscript of APPDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
@@ -50,6 +50,6 @@
  ;second piece is the piece of VAPA this is displayed.
  N APPLIST,LIST,MAX
- S APPLIST("A",1)=" 1 - APPOINTMENT DATE",DATA(SUB,1,1)="APPOINTMENT DATE"_U_1
- S APPLIST("A",2)=" 2 - CLINIC",DATA(SUB,2,2)="CLINIC"_U_2
+ S APPLIST("A",1)=" 1 - APPOINTMENT DATE",APPDATA(1,1)="APPOINTMENT DATE"_U_1
+ S APPLIST("A",2)=" 2 - CLINIC",APPDATA(2,2)="CLINIC"_U_2
  S APPLIST("A")="Enter your selection(s)"
  S APPLIST("?")="^D HELP^PXRMPDRS"
@@ -57,11 +57,11 @@
  S LIST=$$SEL^PXRMPDRS(.APPLIST,2)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
- I DATA(SUB,"LEN")=0 Q
- S DATA(SUB,"MAX")=$$ASKNUM^PXRMEUT("Maximum number of appointments to display",1,25)
+ S APPDATA=LIST
+ S APPDATA("LEN")=$L(LIST,",")-1
+ I APPDATA("LEN")=0 Q
+ S APPDATA("MAX")=$$ASKNUM^PXRMEUT("Maximum number of appointments to display",1,25)
  Q
  ;
-DATASEL(LISTIEN,DATA,SUB) ; Build a list of data that is availble for
+DATASEL(LISTIEN,FINDDATA) ; Build a list of data that is availble for
  ;this patient list and let the user select what they want.
  N IND,DATALIST,DTYPE
@@ -69,7 +69,7 @@
  F  S DTYPE=$O(^PXRMXP(810.5,LISTIEN,35,"B",DTYPE)) Q:DTYPE=""  D
  . S IND=IND+1,DATALIST("A",IND)=" "_IND_" - "_DTYPE
- . S DATA(SUB,IND,IND)=DTYPE
+ . S FINDDATA(IND,IND)=DTYPE
  ;If there is no data quit.
- I IND=0 S DATA(SUB,"LEN")=0 Q
+ I IND=0 S FINDDATA("LEN")=0 Q
  S DATALIST("A")="Enter your selections(s)"
  S DATALIST("?")="^D HELP^PXRMPDRS"
@@ -77,25 +77,25 @@
  S LIST=$$SEL^PXRMPDRS(.DATALIST,IND)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S FINDDATA=LIST
+ S FINDDATA("LEN")=$L(LIST,",")-1
  Q
  ;
-DEMSEL(DATA,SUB) ;Let the user select the demographic information they want.
- ;The first subscript of DATA is the selection number and the
+DEMSEL(DEMDATA) ;Let the user select the demographic information they want.
+ ;The first subscript of DEMDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
  ;in VADM. The first piece of DEMDATA is the name of the data and the
  ;second piece is the piece of VADM this is displayed.
  N DEMLIST,DTOUT,DUOUT,IND,ITEM,JND,KND,LIST,TEMP
- S DEMLIST("A",1)=" 1 - SSN",DATA(SUB,1,2)="SSN"_U_2
- S DEMLIST("A",2)=" 2 - DATE OF BIRTH",DATA(SUB,2,3)="DOB"_U_2
- S DEMLIST("A",3)=" 3 - AGE",DATA(SUB,3,4)="AGE"_U_1
- S DEMLIST("A",4)=" 4 - SEX",DATA(SUB,4,5)="SEX"_U_2
- S DEMLIST("A",5)=" 5 - DATE OF DEATH",DATA(SUB,5,6)="DOD"_U_2
- S DEMLIST("A",6)=" 6 - REMARKS",DATA(SUB,6,7)="REMARKS"_U_1
- S DEMLIST("A",7)=" 7 - HISTORIC RACE",DATA(SUB,7,8)="HISTORIC RACE"_U_2
- S DEMLIST("A",8)=" 8 - RELIGION",DATA(SUB,8,9)="RELIGION"_U_2
- S DEMLIST("A",9)=" 9 - MARITAL STATUS",DATA(SUB,9,10)="MARTIAL STATUS"_U_2
- S DEMLIST("A",10)="10 - ETHNICITY",DATA(SUB,10,11)="ETHNICITY"_U_2
- S DEMLIST("A",11)="11 - RACE",DATA(SUB,11,12)="RACE"_U_2
+ S DEMLIST("A",1)=" 1 - SSN",DEMDATA(1,2)="SSN"_U_2
+ S DEMLIST("A",2)=" 2 - DATE OF BIRTH",DEMDATA(2,3)="DOB"_U_2
+ S DEMLIST("A",3)=" 3 - AGE",DEMDATA(3,4)="AGE"_U_1
+ S DEMLIST("A",4)=" 4 - SEX",DEMDATA(4,5)="SEX"_U_2
+ S DEMLIST("A",5)=" 5 - DATE OF DEATH",DEMDATA(5,6)="DOD"_U_2
+ S DEMLIST("A",6)=" 6 - REMARKS",DEMDATA(6,7)="REMARKS"_U_1
+ S DEMLIST("A",7)=" 7 - HISTORIC RACE",DEMDATA(7,8)="HISTORIC RACE"_U_2
+ S DEMLIST("A",8)=" 8 - RELIGION",DEMDATA(8,9)="RELIGION"_U_2
+ S DEMLIST("A",9)=" 9 - MARITAL STATUS",DEMDATA(9,10)="MARTIAL STATUS"_U_2
+ S DEMLIST("A",10)="10 - ETHNICITY",DEMDATA(10,11)="ETHNICITY"_U_2
+ S DEMLIST("A",11)="11 - RACE",DEMDATA(11,12)="RACE"_U_2
  S DEMLIST("A")="Enter your selection(s)"
  S DEMLIST("?")="^D HELP^PXRMPDRS"
@@ -103,21 +103,21 @@
  S LIST=$$SEL^PXRMPDRS(.DEMLIST,11)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
- F IND=1:1:DATA(SUB,"LEN") D
+ S DEMDATA=LIST
+ S DEMDATA("LEN")=$L(LIST,",")-1
+ F IND=1:1:DEMDATA("LEN") D
  . S JND=$P(LIST,",",IND)
- . S KND=$O(DATA(SUB,JND,""))
- . S TEMP=$P(DATA(SUB,JND,KND),U,1)
+ . S KND=$O(DEMDATA(JND,""))
+ . S TEMP=$P(DEMDATA(JND,KND),U,1)
  . I TEMP="SSN" D
  .. N FULLSSN
  .. D SSN^PXRMXSD(.FULLSSN)
- .. S DATA(SUB,"FULLSSN")=$S($G(FULLSSN)="Y":1,1:0)
- . I $D(DTOUT)!$D(DUOUT) S IND=DATA(SUB,"LEN")+1 Q
- . I TEMP="ETHNICITY" S $P(DATA(SUB,10,11),U,3)=$$ASKNUM^PXRMEUT("Maximum number of ethnicity entries to display",1,10)
- . I TEMP="RACE" S $P(DATA(SUB,11,12),U,3)=$$ASKNUM^PXRMEUT("Maximum number of race entries to display",1,10)
+ .. S DEMDATA("FULLSSN")=$S($G(FULLSSN)="Y":1,1:0)
+ . I $D(DTOUT)!$D(DUOUT) S IND=DEMDATA("LEN")+1 Q
+ . I TEMP="ETHNICITY" S $P(DEMDATA(10,11),U,3)=$$ASKNUM^PXRMEUT("Maximum number of ethnicity entries to display",1,10)
+ . I TEMP="RACE" S $P(DEMDATA(11,12),U,3)=$$ASKNUM^PXRMEUT("Maximum number of race entries to display",1,10)
  I $D(DTOUT)!$D(DUOUT) K DTOUT,DUOUT G DSEL
  Q
  ;
-ELIGSEL(DATA,SUB) ;Let the user select the eligibility data they want.
+ELIGSEL(ELIGDATA) ;Let the user select the eligibility data they want.
  ;The first subscript of ELIGDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
@@ -125,11 +125,11 @@
  ;second piece is the piece of VAEL this is displayed.
  N ELIGLIST,ITEM,LIST
- S ELIGLIST("A",1)=" 1 - PRIMARY ELGIBILITY CODE",DATA(SUB,1,1)="PRIMARY ELGIBILITY CODE"_U_2
- S ELIGLIST("A",2)=" 2 - PERIOD OF SERVICE",DATA(SUB,2,2)="PERIOD OF SERVICE"_U_2
- S ELIGLIST("A",3)=" 3 - % SERVICE CONNECTED",DATA(SUB,3,3)="% SERVICE CONNECTED"_U_2
- S ELIGLIST("A",4)=" 4 - VETERAN",DATA(SUB,4,4)="VETERAN"_U_1
- S ELIGLIST("A",5)=" 5 - TYPE",DATA(SUB,5,6)="TYPE"_U_2
- S ELIGLIST("A",6)=" 6 - ELIGIBILITY STATUS",DATA(SUB,6,8)="ELIGIBILITY STATUS"_U_2
- S ELIGLIST("A",7)=" 7 - CURRENT MEANS TEST",DATA(SUB,7,9)="CURRENT MEANS TEST"_U_2
+ S ELIGLIST("A",1)=" 1 - PRIMARY ELGIBILITY CODE",ELIGDATA(1,1)="PRIMARY ELGIBILITY CODE"_U_2
+ S ELIGLIST("A",2)=" 2 - PERIOD OF SERVICE",ELIGDATA(2,2)="PERIOD OF SERVICE"_U_2
+ S ELIGLIST("A",3)=" 3 - % SERVICE CONNECTED",ELIGDATA(3,3)="% SERVICE CONNECTED"_U_2
+ S ELIGLIST("A",4)=" 4 - VETERAN",ELIGDATA(4,4)="VETERAN"_U_1
+ S ELIGLIST("A",5)=" 5 - TYPE",ELIGDATA(5,6)="TYPE"_U_2
+ S ELIGLIST("A",6)=" 6 - ELIGIBILITY STATUS",ELIGDATA(6,8)="ELIGIBILITY STATUS"_U_2
+ S ELIGLIST("A",7)=" 7 - CURRENT MEANS TEST",ELIGDATA(7,9)="CURRENT MEANS TEST"_U_2
  S ELIGLIST("A")="Enter your selection(s)"
  S ELIGLIST("?")="^D HELP^PXRMPDRS"
@@ -137,6 +137,6 @@
  S LIST=$$SEL^PXRMPDRS(.ELIGLIST,7)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S ELIGDATA=LIST
+ S ELIGDATA("LEN")=$L(LIST,",")-1
  Q
  ;
@@ -147,5 +147,5 @@
  Q
  ;
-INPSEL(DATA,SUB) ;Let the user select the inpatient information they want.
+INPSEL(INPDATA) ;Let the user select the inpatient information they want.
  ;The first subscript of INPDATA is the selection number and the
  ;the second subscript is the subscript where the data is returned
@@ -153,8 +153,8 @@
  ;second piece is the piece of VAIN this is displayed.
  N INPLIST,ITEM,LIST
- S INPLIST("A",1)=" 1 - WARD LOCATION",DATA(SUB,1,4)="WARD"_U_2
- S INPLIST("A",2)=" 2 - ROOM-BED",DATA(SUB,2,5)="ROOM-BED"_U_1
- S INPLIST("A",3)=" 3 - ADMISSION DATE/TIME",DATA(SUB,3,7)="ADMISSION DATE/TIME"_U_2
- S INPLIST("A",4)=" 4 - ATTENDING PHYSICIAN",DATA(SUB,4,11)="ATTENDING"_U_2
+ S INPLIST("A",1)=" 1 - WARD LOCATION",INPDATA(1,4)="WARD"_U_2
+ S INPLIST("A",2)=" 2 - ROOM-BED",INPDATA(2,5)="ROOM-BED"_U_1
+ S INPLIST("A",3)=" 3 - ADMISSION DATE/TIME",INPDATA(3,7)="ADMISSION DATE/TIME"_U_2
+ S INPLIST("A",4)=" 4 - ATTENDING PHYSICIAN",INPDATA(4,11)="ATTENDING"_U_2
  S INPLIST("A")="Enter your selection(s)"
  S INPLIST("?")="^D HELP^PXRMPDRS"
@@ -162,11 +162,11 @@
  S LIST=$$SEL^PXRMPDRS(.INPLIST,5)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S INPDATA=LIST
+ S INPDATA("LEN")=$L(LIST,",")-1
  Q
  ;
-REMSEL(PLIEN,DATA,SUB) ;If the list was generated from a reminder report
+REMSEL(PLIEN,REMDATA) ;If the list was generated from a reminder report
  ;let the user select the reminder data they want.
- I '$P(^PXRMXP(810.5,PLIEN,0),U,9) S DATA(SUB,"LEN")=0 Q
+ I '$P(^PXRMXP(810.5,PLIEN,0),U,9) S REMDATA("LEN")=0 Q
  N IEN,IND,REMLIST,RNAME
  S (IEN,IND)=0
@@ -175,6 +175,6 @@
  . I RNAME="" S RNAME=$P(^PXD(811.9,IEN,0),U,1)
  . S IND=IND+1
- . S DATA(SUB,"RNAME",IND)=RNAME
- . S DATA(SUB,"IEN",IND)=IEN
+ . S REMDATA("RNAME",IND)=RNAME
+ . S REMDATA("IEN",IND)=IEN
  . S REMLIST("A",IND)=" "_IND_" - "_RNAME
  S REMLIST("A")="Enter your selection(s)"
@@ -183,6 +183,6 @@
  S LIST=$$SEL^PXRMPDRS(.REMLIST,IND)
  I $D(DTOUT)!$D(DUOUT) Q
- S DATA(SUB)=LIST
- S DATA(SUB,"LEN")=$L(LIST,",")-1
+ S REMDATA=LIST
+ S REMDATA("LEN")=$L(LIST,",")-1
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;01/24/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;06/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Input  :  RIEN     - Reminder IEN
@@ -7,9 +7,10 @@
  ;          PXRMDATE - Evaluation date
  ;===================================================
-BLDPLST(DEFARR,PLIST,DFNONLY) ;
- N DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
+BLDPLST(RIEN,PLIST,DFNONLY,PXRMDATE) ;
+ N DEFARR,DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
  N LIST1,LIST2,LNAME,LSP,LSTACK
  N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
  ;
+ D DEF^PXRMLDR(RIEN,.DEFARR)
  ;Get the cohort logic string. This has passed a validation before
  ;it can be selected for building patient lists so we don't need to
@@ -229,5 +230,5 @@
  N DFN,DS,IND,SEXOK
  F IND=1:1:NDR D
- . S DS=DOBS(IND)-.000001
+ . S DS=DOBS(IND)-.1
  . F  S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="")  D
  .. S DFN=""
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTD2.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMPTD2 ; SLC/PKR/PJH - Reminder Inquiry print template routines.;03/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPTD2 ; SLC/PKR/PJH - Reminder Inquiry print template routines.;10/07/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;================================================
 DATE(FIND0,PIECE,FLDNUM,TITLE,RJC,PAD,FILENUM,FLG) ;Standard DATE
@@ -6,5 +6,5 @@
  S DATE=$P($G(FIND0),U,PIECE)
  I DATE'="" D
- .S DATE=$$FMTE^XLFDT(DATE,"5Z"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE
+ .S DATE=$$FMTE^XLFDT(DATE,"D"),X=$$RJ^XLFSTR(TITLE,RJC,PAD),X=X_" "_DATE
  .D ^DIWP
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTDF.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;06/07/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPTDF ; SLC/PKR/PJH - Reminder Inquiry print template routines. ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;================================================
@@ -81,5 +81,5 @@
  .D SFDISP(FIND0,1,14,"Condition:",RJC,PAD,FILENUM)
  .D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD,FILENUM)
- .D SFDISP(FIND0,3,18,"Use Status/Cond in Search:",RJC,PAD,FILENUM)
+ .D SFDISP(FIND0,3,18,"Use Cond in Finding Search:",RJC,PAD,FILENUM)
  .I $G(^PXD(811.9,D0,20,FINDING,15))'="" D 
  ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
@@ -173,5 +173,5 @@
  .D SFDISP(TERM3,1,14,"Condition:",RJT,PAD,TERMNUM,1)
  .D SFDISP(TERM3,2,15,"Condition Case Sensitive:",RJT,PAD,TERMNUM)
- .D SFDISP(TERM3,3,18,"Use Status/Cond in Search:",RJT,PAD,TERMNUM)
+ .D SFDISP(TERM3,3,18,"Use Cond in Finding Search:",RJT,PAD,TERMNUM)
  .I $G(^PXRMD(811.5,IEN1,20,TERMS,15))'="" D 
  ..S X=$$RJ^XLFSTR("Computed Finding Parameter:",RJT,PAD)
@@ -215,16 +215,6 @@
  .S X=$$RJ^XLFSTR(TITLE,RJC,PAD)
  .S X=X_" "_$$EXTERNAL^DILFD(FILENUM,FLDNUM,"",FIELD,"")
- .I FLDNUM=13 S X=X_" - "_$$SPECIAL(FIND0,FIELD)
- .D ^DIWP
- Q
- ;
- ;================================================
-SPECIAL(FIND0,FIELD) ;Special output for certain fields.
- N FINDING,GLOBAL,IEN
- S FINDING=$P(FIND0,U,1)
- S IEN=$P(FINDING,";",1)
- S GLOBAL=$P(FINDING,";",2)
- I GLOBAL="YTT(601.71," Q $$SCNAME^PXRMMH(IEN,FIELD)
- Q ""
+ .D ^DIWP
+ Q
  ;
  ;================================================
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPTTR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMPTTR ;SLC/PKR - Routines for term print templates ;06/01/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMPTTR ;SLC/PKR - Routines for term print templates ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;====================================================
@@ -88,5 +88,5 @@
  . D SFDISP(FIND0,1,14,"Condition:",RJC,PAD)
  . D SFDISP(FIND0,2,15,"Condition Case Sensitive:",RJC,PAD)
- . D SFDISP(FIND0,3,18,"Use Status/Cond in Search:",RJC,PAD)
+ . D SFDISP(FIND0,3,18,"Use Cond in Finding Search:",RJC,PAD)
  . I $G(^PXRMD(811.5,D0,20,FINDING,15))'="" D
  .. S CFP=$$RJ^XLFSTR("Computed Finding Parameter:",RJC,PAD)
@@ -103,5 +103,4 @@
  . S TEXT=$$RJ^XLFSTR(TITLE,RJC,PAD)
  . S TEXT=TEXT_"  "_$$EXTERNAL^DILFD(811.52,FLDNUM,"",FIELD,"")
- . I FLDNUM=13 S TEXT=TEXT_" - "_$$SPECIAL^PXRMPTDF(FIND0,FIELD)
  . W !,TEXT
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMREDF.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;01/09/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMREDF ; SLC/PJH - Edit PXRM reminder findings. ;02/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ; Called by PXRMREDT which newes and initialized DEF, DEF1, DEF2.
@@ -37,5 +37,4 @@
  D ^DIC I Y=-1 S DTOUT=1 Q
  S DIE=DIC K DIC
- S DIE("NO^")="OUTOK"
  S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
  S TYPE=$G(DEF1(GLOB))
@@ -43,4 +42,5 @@
  ;Save term IEN
  S STATUS=0
+ I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
  I TYPE="CF" S CFIEN=$P($P(Y,U,2),";",1) D
  .I $D(^PXRMD(811.4,CFIEN,1))>0 D
@@ -49,6 +49,4 @@
  ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
  .E  W !!,"No description defined for this computed finding"
- I TYPE="MH" D WARN^PXRMMH
- I TYPE="RT" S TIEN=$P($P(Y,U,2),";",1)
  ;Finding record fields
  W !!,"Editing Finding Number: "_$G(DA)
@@ -99,5 +97,5 @@
  ;Check if deleted
  I '$D(DA) Q
- I STATUS=1,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"D")
+ I STATUS=1 D STATUS^PXRMSTA1(.DA,"D")
  ;
  S ETYPE=$P(^PXD(811.9,IEN,20,SDA(1),0),U,1)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMREDT.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;10/04/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMREDT ; SLC/PKR,PJH - Edit PXRM reminder definition. ;02/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;=======================================================
@@ -17,5 +17,4 @@
  D SETSTART^PXRMCOPY(DIC)
  W !
- S DIC("W")="W $$LUDISP^PXRMREDT(Y)"
  D ^DIC
  I ($D(DTOUT))!($D(DUOUT)) Q
@@ -288,16 +287,6 @@
  ;
  ;-------------------------------------
-LUDISP(IEN) ;Use for DIC("W") to augment look-up display.
- N CLASS,EM,INACTIVE,TEXT
- S INACTIVE=$P(^PXD(811.9,IEN,0),U,6)
- S CLASS=$P(^PXD(811.9,IEN,100),U,1)
- I INACTIVE'="" S INACTIVE="("_$$EXTERNAL^DILFD(811.9,1.6,"",INACTIVE,.EM)_")"
- S CLASS=$$EXTERNAL^DILFD(811.9,100,"",CLASS,.EM)
- S TEXT="  "_CLASS_" "_INACTIVE
- Q TEXT
- ;
- ;-------------------------------------
 TFIND(DA,LIST) ;Allow edit of term findings for national reminders.
- N DIR,IENLIST,IND,JND,NAME,NAMELIST,SUB,X,Y
+ N DIR,IENLIST,IND,NAME,NAMELIST,SUB,X,Y
  S IND=0,NAME=""
  F  S NAME=$O(LIST("RT",NAME)) Q:NAME=""  D
@@ -313,9 +302,9 @@
  I $D(DIROUT)!$D(DIRUT) S LIST="" Q
  I $D(DUOUT)!$D(DTOUT) S LIST="" Q
+ S LIST=Y
  F IND=1:1:$L(Y,",")-1 D
- . S JND=$P(Y,",",IND)
- . S NAME=$P(NAMELIST(JND),JND,2)
+ . S NAME=$P(NAMELIST(IND),IND,2)
  . W !!,"Reminder Term:",NAME
- . D TMAP^PXRMREDF(DA,IENLIST(JND))
- Q
- ;
+ . D TMAP^PXRMREDF(DA,IENLIST(IND))
+ Q
+ ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRPCC.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;11/26/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMRPCC ;SLC/PJH - PXRM REMINDER DIALOG ;04/12/2002
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
 ACTIVE(ORY,ORREM) ;Check if active dialog exist for reminders
@@ -39,5 +39,4 @@
  ;
  ;Load dialog lines into local array
- S ORY(0)=0_U_+$P($G(^PXRMD(801.41,DIEN,0)),U,17)
  D LOAD^PXRMDLL(DIEN,$G(DFN))
  Q
@@ -77,9 +76,7 @@
  ; Input mental health instrument NAME
  ;
- K ^TMP($J,"YSQU")
- N ARRAY,CNT,CNT1,FNODE,FSUB,IC,NODE,OCNT,SUB,YS
- ;DBIA #5056
- S YS("CODE")=OTEST D SHOWALL^YTQPXRM5(.ARRAY,.YS)
- S OCNT=0,CNT=0
+ N YS,ARRAY S YS("CODE")=OTEST D SHOWALL^YTAPI3(.ARRAY,.YS) ; DBIA #2895
+ ;
+ N FNODE,FSUB,IC,NODE,OCNT,SUB
  S SUB="ARRAY",OCNT=0
  F  S SUB=$Q(@SUB) Q:SUB=""  D
@@ -96,5 +93,5 @@
  ; Input MH result IEN and mental health instrument response
  ;
- D START^PXRMDLR(.ORY,RESULT,.ORES)
+ D ^PXRMDLR
  ;
  Q
@@ -103,10 +100,8 @@
  ;
  ; Input mental health instrument response
- N ANS,ARRAY,X
- S ANS=$G(YS("R1")) K YS("R1")
- S YS("ADATE")=YS("ADATE")_"."_$P($$NOW^XLFDT,".",2)
- F X=1:1:$L(ANS) I $E(ANS,X)'="X" S YS(X)=X_U_$E(ANS,X)
- ;DBIA #4463
- D SAVECR^YTQPXRM4(.ARRAY,.YS)
+ N ARRAY
+ D SAVEIT^YTAPI1(.ARRAY,.YS) ; DBIA #2893
+ I ARRAY(1)'="[DATA]" S ORY(1)="-1^"_ARRAY(1)_ARRAY(2)
+ I ARRAY(1)="[DATA]" S ORY(1)=ARRAY(1)_ARRAY(2)
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRUL1.m	(revision 636)
@@ -1,126 +1,9 @@
-PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 03/29/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMRUL1 ; SLC/AGP,PKR - Patient list routines. ; 08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
- ;
-ASK(PLIEN,OPT) ;Verify patient list name
- N X,Y,TEXT
- K DIROUT,DIRUT,DTOUT,DUOUT
- S DIR(0)="YA0"
- S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
- S DIR("B")="N"
- S DIR("?")="Enter Y or N. For detailed help type ??"
- W !
- D ^DIR K DIR
- I $D(DIROUT) S DTOUT=1
- I $D(DTOUT)!($D(DUOUT)) Q
- I $E(Y(0))="N" S DUOUT=1 Q
- Q
- ;
-COPY(IENO) ;Copy patient list
- ;Check if OK to copy
- D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
- N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
- ;Select list to copy to
- S TEXT="Select PATIENT LIST name to copy to: "
- D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
- S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
- ;
- ;Get original Patient List record 
- S ODATA=$G(^PXRMXP(810.5,IENO,0))
- S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
- ;
- M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
- D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
- ;Update header info
- S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
- S IND=IENN_","
- S FDA(810.5,IND,.01)=NNAME
- S FDA(810.5,IND,.04)=$$NOW^XLFDT
- S FDA(810.5,IND,.05)=OEPIEN
- S FDA(810.5,IND,.06)=ORULE
- S FDA(810.5,IND,.07)=$G(DUZ)
- S FDA(810.5,IND,.08)=TYPE
- D UPDATE^DIE("","FDA","","MSG")
- ;Error
- I $D(MSG) D ERR
- ;
- W !!,"Completed copy of '"_ONAME_"'"
- W !,"into '"_NNAME_"'",! H 2
- K ^TMP($J,"PXRMRULE")
- Q
- ;
-CRLST(NAME,CLASS) ;Create new patient list
- N IEN
- ;Check if name exists
- S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
- ;Otherwise create national entry
- N FDA,FDAIEN,MSG
- S FDA(810.5,"+1,",.01)=NAME
- S FDA(810.5,"+1,",100)=CLASS
- S FDA(810.5,"+1,",.07)=$G(DUZ)
- ;Make stub public
- S FDA(810.5,"+1,",.08)="PUB"
- D UPDATE^DIE("","FDA","FDAIEN","MSG")
- ;Error
- I $D(MSG) Q 0
- ;Otherwise list ien
- Q FDAIEN(1)
- ;
-COUNT(NODE) ;Count the number of entries.
- N DFN,NUM
- S (DFN,NUM)=0
- F  S DFN=$O(^TMP($J,NODE,DFN)) Q:DFN=""  S NUM=NUM+1
- Q NUM
- ;
-DELETE(LIST) ;Delete Patient list
- I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
- .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
- .S DUOUT=1
- ;Check if this is the right list
- D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
- ;
- N DA,DIK,DUOUT
- ;Lock patient list
- D LOCK Q:$D(DUOUT)
- ;Kill List
- S DA=LIST,DIK="^PXRMXP(810.5,"
- D ^DIK
- ;Unlock patient list
- D UNLOCK
- Q
- ;
 DATECHK(DATE) ;
  I DATE=0 Q 1
  S DATE=$$STRREP^PXRMUTIL(DATE,"BDT","T")
  Q $$VDT^PXRMINTR(DATE)
- ;
-DATES(LBBDT,LBEDT,RBDT,REDT,FARR) ;Set the dates in the finding array to
- ;FileMan dates.
- N FI,PXRMDATE,TBDT,TEDT
- S FI=0
- F  S FI=+$O(FARR(20,FI)) Q:FI=0  D
- . S TBDT=$P(FARR(20,FI,0),U,8),TEDT=$P(FARR(20,FI,0),U,11)
- . I TBDT="",TEDT="" D
- .. S $P(FARR(20,FI,0),U,8)=RBDT,$P(FARR(20,FI,0),U,11)=REDT
- . E  D
- .. S PXRMDATE=$S(TBDT["BDT":LBBDT,1:LBEDT)
- .. S TBDT=$S(TBDT="":0,TBDT=0:0,TBDT="BDT":LBBDT,1:$$CTFMD^PXRMDATE(TBDT))
- .. S PXRMDATE=$S(TEDT["BDT":LBBDT,1:LBEDT)
- .. S TEDT=$S(TEDT="":"T",TEDT=0:"T",TEDT="BDT":LBBDT,1:TEDT)
- .. S TEDT=$$CTFMD^PXRMDATE(TEDT)
- .. S $P(FARR(20,FI,0),U,8)=TBDT,$P(FARR(20,FI,0),U,11)=TEDT
- Q
- ;
-ERR ;Error Handler
- N ERROR,IC,REF
- S ERROR(1)="Unable to build patient list : "
- S ERROR(2)=NAME
- S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
- ; Move MSG into Error
- S REF="MSG"
- F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
- ;Screen message
- D EN^DDIOL(.ERROR)
- Q
  ;
 INSERT(FROUT,DFN,TNAME,TFIEV,RSTOP) ;Save patient data.
@@ -153,8 +36,4 @@
  Q INST
  ;
-LOCK L +^PXRMXP(810.5,LIST):0
- E  W !!?5,"Another user is using this patient list" S DUOUT=1
- Q
- ;
 LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
  ;operator LOGOP to generate a new list and return it in LIST1
@@ -178,10 +57,6 @@
  Q
  ;
-REM(FRACT,RIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE) ;Process reminder finding rule
- N DEFFARR,PXRMDATE
- D DEF^PXRMLDR(RIEN,.DEFARR)
- D DATES(LBBDT,LBEDT,RSTART,RSTOP,.DEFARR)
- S PXRMDATE=RSTOP
- D BLDPLST^PXRMPLST(.DEFARR,PNODE,1)
+REM(FRACT,RIEN,RSTART,RSTOP,PNODE) ;Process reminder finding rule
+ D BLDPLST^PXRMPLST(RIEN,PNODE,1,RSTOP)
  ;Remove, Select or Add Findings operations
  I FRACT="A" D LOGOP(FROUT,PNODE,"!") Q
@@ -190,14 +65,11 @@
  Q
  ;
-TERM(FRACT,FRTIEN,LBBDT,LBEDT,RSTART,RSTOP,PNODE,INST) ;Process TERM finding
- ;rules
- N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG
- N TERMARR,TFIEV,TNAME
+TERM(FRACT,FRTIEN,RSTART,RSTOP,PNODE,INST) ;Process TERM finding rule
+ N FINDPA,FINDING,FNAME,PLIST,PXRMDATE,PXRMDEBG,TERMARR,TFIEV,TNAME
  ;Get term definition array
  D TERM^PXRMLDR(FRTIEN,.TERMARR)
  S TNAME=$P(TERMARR(0),U,1)
  S INST=$S(FRACT'="F":0,TNAME="VA-PCMM INSTITUTION":1,TNAME="VA-IHD STATION CODE":1,1:0)
- ;Set begin and end dates in the term.
- D DATES(LBBDT,LBEDT,RSTART,RSTOP,.TERMARR)
+ ;Set start and end dates
  S $P(FINDPA(0),U,8)=RSTART,$P(FINDPA(0),U,11)=RSTOP,PXRMDATE=RSTOP
  ;
@@ -205,5 +77,5 @@
  I FRACT="A" D  Q
  .;Process term for date range
- .D EVALPL^PXRMTERL(.FINDPA,.TERMARR,PNODE)
+ .D EVALPL^PXRMTERM(.FINDPA,.TERMARR,PNODE)
  .;Merge lists if operation is add
  .M ^TMP($J,FROUT)=^TMP($J,PNODE,1)
@@ -226,4 +98,2 @@
  Q
  ;
-UNLOCK L -^PXRMXP(810.5,LIST) Q
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m	(revision 636)
@@ -1,6 +1,20 @@
-PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;03/27/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;08/11/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ; Called from PXRM PATIENT LIST CREATE protocol
+ ;
+ASK(PLIEN,OPT) ;Verify patient list name
+ N X,Y,TEXT
+ K DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="YA0"
+ S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
+ S DIR("B")="N"
+ S DIR("?")="Enter Y or N. For detailed help type ??"
+ W !
+ D ^DIR K DIR
+ I $D(DIROUT) S DTOUT=1
+ I $D(DTOUT)!($D(DUOUT)) Q
+ I $E(Y(0))="N" S DUOUT=1 Q
+ Q
  ;
 CLEAR(RULE,NODE) ;Clear workfile entries
@@ -13,4 +27,80 @@
  Q
  ;
+COPY(IENO) ;Copy patient list
+ ;Check if OK to copy
+ D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
+ N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
+ ;Select list to copy to
+ S TEXT="Select PATIENT LIST name to copy to: "
+ D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT)  Q:'IENN
+ S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
+ ;
+ ;Get original Patient List record 
+ S ODATA=$G(^PXRMXP(810.5,IENO,0))
+ S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
+ ;
+ M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
+ D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
+ ;Update header info
+ S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
+ S IND=IENN_","
+ S FDA(810.5,IND,.01)=NNAME
+ S FDA(810.5,IND,.04)=$$NOW^XLFDT
+ S FDA(810.5,IND,.05)=OEPIEN
+ S FDA(810.5,IND,.06)=ORULE
+ S FDA(810.5,IND,.07)=$G(DUZ)
+ S FDA(810.5,IND,.08)=TYPE
+ D UPDATE^DIE("","FDA","","MSG")
+ ;Error
+ I $D(MSG) D ERR
+ ;
+ W !!,"Completed copy of '"_ONAME_"'"
+ W !,"into '"_NNAME_"'",! H 2
+ K ^TMP($J,"PXRMRULE")
+ Q
+ ;
+CRLST(NAME,CLASS) ;Create new patient list
+ N IEN
+ ;Check if name exists
+ S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
+ ;Otherwise create national entry
+ N FDA,FDAIEN,MSG
+ S FDA(810.5,"+1,",.01)=NAME
+ S FDA(810.5,"+1,",100)=CLASS
+ D UPDATE^DIE("","FDA","FDAIEN","MSG")
+ ;Error
+ I $D(MSG) Q 0
+ ;Otherwise list ien
+ Q FDAIEN(1)
+ ;
+DELETE(LIST) ;Delete Patient list
+ I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D  Q
+ .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
+ .S DUOUT=1
+ ;Check if this is the right list
+ D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
+ ;
+ N DA,DIK,DUOUT
+ ;Lock patient list
+ D LOCK Q:$D(DUOUT)
+ ;Kill List
+ S DA=LIST,DIK="^PXRMXP(810.5,"
+ D ^DIK
+ ;Unlock patient list
+ D UNLOCK
+ Q
+ ;
+ERR ;Error Handler
+ N ERROR,IC,REF
+ S ERROR(1)="Unable to build patient list : "
+ S ERROR(2)=NAME
+ S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
+ ; Move MSG into Error
+ S REF="MSG"
+ F IC=4:1 S REF=$Q(@REF) Q:REF=""  S ERROR(IC)=REF_"="_@REF
+ ;Screen message
+ D EN^DDIOL(.ERROR)
+ Q
+ ;
 INTR ;Input transform for #810.4 fields
  Q
@@ -25,5 +115,9 @@
  Q
  ;
-PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule
+LOCK L +^PXRMXP(810.5,LIST):0
+ E  W !!?5,"Another user is using this patient list" S DUOUT=1
+ Q
+ ;
+PATS(LIST) ;Process Patient List finding rule
  ;
  N LIEN,LUVALUE
@@ -38,17 +132,18 @@
  I FRACT="A" D LOAD(FROUT,LIEN) Q
  ;
- ;Remove or Select operations
- ;Load List
- D LOAD(PNODE,LIEN)
- ;Check each patient
- S DFN=0
- F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
- .;Delete any ^TMP patient in PLIST if action is remove
- .I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
- .;Delete any ^TMP patient not in PLIST if action is select
- .I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
- Q
- ;
-START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR) ;
+ ;Remove, Select or Add Findings operations
+ I FRACT'="A" D  Q
+ .;Load List
+ .D LOAD(PNODE,LIEN)
+ .;Check each patient
+ .S DFN=0
+ .F  S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN  D
+ ..;Delete any ^TMP patient in PLIST if action is remove
+ ..I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
+ ..;Delete any ^TMP patient not in PLIST if action is select
+ ..I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
+ Q
+ ;
+START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP) ;
  ;Process rule set
  ;Clear ^TMP
@@ -56,5 +151,5 @@
  ;
  N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
- N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
+ N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE
  N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
  ;Get class from extract parameter
@@ -62,9 +157,6 @@
  ;Otherwise default to local
  I $G(CLASS)="" S CLASS="L"
- ;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
- S PXRMDDOC=1
- K ^TMP("PXRMDDOC",$J)
  ;Get each finding rule in sequence
- S SEQ="",INC=0,INST=0
+ S SEQ="",INC=0
  F  S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ  D
  .;Save first sequence as default
@@ -84,5 +176,4 @@
  .;Get Extract Patient List name for patient list rule
  .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D  Q:FRLST=""
- ..I +EXTITR>0 S FRLST=FRLST_"/"_EXTITR
  ..S FROLST=$P(FRDATA,U,8)
  ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
@@ -106,9 +197,9 @@
  .K ^TMP($J,PNODE)
  .;Term finding rules
- .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
+ .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST)
  .;Reminder Definition List Rule
- .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
+ .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE)
  .;Patient list finding rules
- .I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
+ .I FRTYP=5 D PATS(FRLST)
  .;Clear results file
  .K ^TMP($J,PNODE)
@@ -118,47 +209,31 @@
  ..N FRPIEN
  ..;Get patient list IEN or create new patient list
- ..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
+ ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN
  ..;Update patient list
- ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
+ ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST)
  ;
  ;Save final results to patient list
  I LIST'="",FROUT'="" D
  . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
- . D UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
- .;PXRMDDOC=2 compare saved dates with those generated in
- .;DOCUMENT^PXRMEUT.
- . S PXRMDDOC=2
+ . D UPDLST(FROUT,LIST,PAR,RULESET,INST)
  . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
- K ^TMP("PXRMDDOC",$J)
- Q
- ;
-UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP) ;Update patient list
- N CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
- N INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
- N RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
+ Q
+ ;
+UPDLST(NODE,LIST,EPIEN,RULE,INST) ;Update patient list
+ N CNT,DA,DATA,DCNT,DFN,DNAME,DNAMEL,DUE,DUOUT,FDA,INST,INSTNAM,INSTNUM
+ N LAST,MSG,NAME,ONODE,RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TYPE,VALUE
  ;Lock patient list
- D LOCK^PXRMRUL1 Q:$D(DUOUT)
- S TEMP=^PXRMXP(810.5,LIST,0)
- S NAME=$P(TEMP,U,1)
- S $P(^PXRMXP(810.5,LIST,0),U,11)=INDP
- S $P(^PXRMXP(810.5,LIST,0),U,12)=INTP
+ D LOCK Q:$D(DUOUT)
  ;
  ;Clear existing list.
  K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
+ S NAME=$P($G(^PXRMXP(810.5,LIST,0)),U)
  ;
  ;Merge ^TMP into Patient List
- S (DECEASED,TESTP)=""
- S (CNT,DFN)=0
+ S (CNT,DFN,INST)=0
  F  S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN  D
  .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
  .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
- .S TEMP=DFN_U_INSTNUM_U_INSTNAM
- .I INDP D
- ..;DBIA #10035
- ..S DOD=+$P($G(^DPT(DFN,.35)),U,1)
- ..S DECEASED=$S(DOD=0:0,1:1)
- .;DBIA #3744
- .I INTP S TESTP=$$TESTPAT^VADPT(DFN)
- .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
+ .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM
  .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
  .;
@@ -215,7 +290,9 @@
  D UPDATE^DIE("","FDA","","MSG")
  ;Error
- I $D(MSG) D ERR^PXRMRUL1
+ I $D(MSG) D ERR
  ;Unlock patient list
- D UNLOCK^PXRMRUL1
- Q
- ;
+ D UNLOCK
+ Q
+ ;
+UNLOCK L -^PXRMXP(810.5,LIST) Q
+ ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSTA1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMSTA1 ; SLC/AGP - Routines for building status list. ;09/06/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMSTA1 ; SLC/AGP - Routines for building status list. ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;This routine and PXRMSTA2 will allow users to select the
@@ -35,5 +35,5 @@
  ;
 ADDDEL(ANS,GBL,FILE,TYPE,NODE,WILD,DA,UPDATE,DELALL) ;
- I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES")
+ I $G(ANS)="" S ANS=$$PROMPT("S^A:ADD STATUS;D:DELETE A STATUS;S:SAVE AND QUIT;Q:QUIT WITHOUT SAVING CHANGES","S")
  I "ADDASQ"'[ANS Q
  I ANS="A",WILD=1 D
@@ -62,7 +62,7 @@
  I TYPE[";" S TYPE=$P($G(TYPE),";",2)
  I TYPE="PXD(811.2," D  G ADDEX
- .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
+ .I $G(TAXTYPE)="R" D DATA^PXRMSTA2(FILE,.DA,"RAMIS(71,","",.STATUS)
  .;I $G(TAXTYPE)="P" D DATA^PXRMSTA2(FILE,.DA,"PROB","",.STATUS)
- .;I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)
+ .I $G(TAXTYPE)="B" D DATA^PXRMSTA2(FILE,.DA,"TAX","",.STATUS)
  ; handle drug finding items
  I TYPE["PSDRUG("!(TYPE["PS(50.605")!(TYPE["PSNDF") D  G ADDEX
@@ -91,6 +91,6 @@
  I TYPE[";" S TYPE=$P($G(TYPE),";",2)
  I TYPE="PXD(811.2," D
- .I $G(TAXTYPE)="R"!($G(TAXTYPE)="B") S FILE=70
- .;I $G(TAXTYPE)="P" S FILE=9000011
+ .I $G(TAXTYPE)="R" S FILE=70
+ .I $G(TAXTYPE)="P" S FILE=9000011
  I FILE="",TYPE="ORD(101.43," S FILE=100
  I FILE="",TYPE="RAMIS(71," S FILE=70
@@ -173,9 +173,9 @@
  Q
  ;
-PROMPT(STR) ;
+PROMPT(STR,DEFAULT) ;
  N DIR,HTEXT
- S HTEXT(1)="Select 'A' to add a status to the current status list.\\Select 'D' to"
- S HTEXT(2)="delete a status from the list.\\Select 'S' to save your changes and quit. "
- S HTEXT(3)="\\Select 'Q' to quit without saving your changes."
+ S HTEXT(1)="Select 'A' to add a status to the current status list. Select 'D' to "
+ S HTEXT(2)="delete a status from the list. Select 'S' to save your changes and quit. "
+ S HTEXT(3)="Select 'Q' to quit without saving your changes."
  S DIR(0)=STR
  S DIR("B")="S"
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSTA2.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMSTA2 ; SLC/AGP - Routines for building status list. ;03/27/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMSTA2 ; SLC/AGP - Routines for building status list. ;9/26/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 DATA(FILE,DA,TYPE,RXTYPE,STATUS) ;
@@ -11,15 +11,12 @@
  I TYPE="DRUG" D
  .I $D(RXTYPE("I"))>0 D
- . . D STATUS^PSS55MIS(55.06,28,"SARRAY")
- . . ;D FIELD^DID(55.06,28,"","POINTER","SARRAY")
+ . . D FIELD^DID(55.06,28,"","POINTER","SARRAY")
  . . D ARRAYFOR(.SARRAY,.ARRAY,"I") K CODE
- . . D STATUS^PSS55MIS(55.01,100,"SARRAY")
- . . ;D FIELD^DID(55.01,100,"","POINTER","SARRAY")
+ . . D FIELD^DID(55.01,100,"","POINTER","SARRAY")
  . . D ARRAYFOR(.SARRAY,.ARRAY1,"I") K CODE
  . . D COMPARE(.ARRAY,.ARRAY1,"I",.OUTPUT)
  . I $D(RXTYPE("O"))>0 D
  . . K ARRAY,ARRAY1,CODE
- . . D STATUS^PSODI(52,100,"SARRAY")
- . . ;D FIELD^DID(52,100,"","POINTER","SARRAY")
+ . . D FIELD^DID(52,100,"","POINTER","SARRAY")
  . . D ARRAYFOR(.SARRAY,.ARRAY,"O") K CODE
  . . I $D(OUTPUT)>0 K ARRAY1 M ARRAY1=OUTPUT K OUTPUT D COMPARE(.ARRAY,.ARRAY1,"",.OUTPUT)
@@ -27,6 +24,5 @@
  . I $D(RXTYPE("N"))>0 D
  . . K ARRAY,ARRAY1,CODE
- . . D STATUS^PSS55MIS(55.05,5,"SARRAY")
- . . ;D FIELD^DID(55.05,5,"","POINTER","SARRAY")
+ . . D FIELD^DID(55.05,5,"","POINTER","SARRAY")
  . . S SARRAY("POINTER")=SARRAY("POINTER")_"0:ACTIVE;"
  . . D ARRAYFOR(.SARRAY,.ARRAY,"N") K CODE
@@ -76,5 +72,5 @@
  ;
 ARRAYFOR(ARRAY,OUTPUT,DEF) ;
- ;this sub routine is use to format the array data into a standard 
+ ;this sub routine is use to format that array data into a standard 
  ;format
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMSXRM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;11/23/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMSXRM ; SLC/PKR - Main driver for building indexes. ;12/20/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;==========================================
@@ -81,5 +81,4 @@
  S ROUTINE(120.5)="VITALS^GMVPXRM"  ;DBIA #3647
  S ROUTINE(601.2)="INDEX^YTPXRM" ;DBIA #4523
- S ROUTINE(601.84)="INDEX^YTQPXRM" ;DBIA #5055
  S ROUTINE(9000011)="INDEX^GMPLPXRM" ;DBIA #4516
  S ROUTINE(9000010.07)="VPOV^PXPXRMI2" ;DBIA #4520
@@ -115,25 +114,24 @@
  ;==========================================
 SEL(LIST,GBL) ;Select global list
- N ALIST,DIR,DIROUT,DIRUT,DTOUT,DUOUT,INUM,X,Y
- S INUM=1,ALIST(INUM)="  "_INUM_" - LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(INUM)=63
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - MENTAL HEALTH",GBL(INUM)=601.2
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - MENTAL HEALTH (MHA3)",GBL(INUM)=601.84
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - ORDER",GBL(INUM)=100
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PTF",GBL(INUM)=45
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PHARMACY PATIENT",GBL(INUM)=55
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PRESCRIPTION",GBL(INUM)=52
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - PROBLEM LIST",GBL(INUM)=9000011
- S INUM=INUM+1,ALIST(INUM)="  "_INUM_" - RADIOLOGY",GBL(INUM)=70
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V CPT",GBL(INUM)=9000010.18
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V EXAM",GBL(INUM)=9000010.13
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V HEALTH FACTORS",GBL(INUM)=9000010.23
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V IMMUNIZATION",GBL(INUM)=9000010.11
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V PATIENT ED",GBL(INUM)=9000010.16
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V POV",GBL(INUM)=9000010.07
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - V SKIN TEST",GBL(INUM)=9000010.12
- S INUM=INUM+1,ALIST(INUM)=" "_INUM_" - VITAL MEASUREMENT",GBL(INUM)=120.5
+ N ALIST,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+ S ALIST(1)="  1 - LABORATORY TEST (CH, Anatomic Path, Micro)",GBL(1)=63
+ S ALIST(2)="  2 - MENTAL HEALTH",GBL(2)=601.2
+ S ALIST(3)="  3 - ORDER",GBL(3)=100
+ S ALIST(4)="  4 - PTF",GBL(4)=45
+ S ALIST(5)="  5 - PHARMACY PATIENT",GBL(5)=55
+ S ALIST(6)="  6 - PRESCRIPTION",GBL(6)=52
+ S ALIST(7)="  7 - PROBLEM LIST",GBL(7)=9000011
+ S ALIST(8)="  8 - RADIOLOGY",GBL(8)=70
+ S ALIST(9)="  9 - V CPT",GBL(9)=9000010.18
+ S ALIST(10)=" 10 - V EXAM",GBL(10)=9000010.13
+ S ALIST(11)=" 11 - V HEALTH FACTORS",GBL(11)=9000010.23
+ S ALIST(12)=" 12 - V IMMUNIZATION",GBL(12)=9000010.11
+ S ALIST(13)=" 13 - V PATIENT ED",GBL(13)=9000010.16
+ S ALIST(14)=" 14 - V POV",GBL(14)=9000010.07
+ S ALIST(15)=" 15 - V SKIN TEST",GBL(15)=9000010.12
+ S ALIST(16)=" 16 - VITAL MEASUREMENT",GBL(16)=120.5
  M DIR("A")=ALIST
  S DIR("A")="Enter your list"
- S DIR(0)="LO^1:"_INUM
+ S DIR(0)="LO^1:16"
  D ^DIR
  I $D(DIROUT)!$D(DIRUT) S LIST="" Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTAX.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;10/11/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMTAX ; SLC/PKR - Handle taxonomy finding. ;07/17/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;==================================================
@@ -65,5 +65,5 @@
  S SDIR=$S(NOCC<0:+1,1:-1)
  S NOCC=$S(NOCC<0:-NOCC,1:NOCC)
- S NGET=$S(UCIFS:50,1:NOCC)
+ S NGET=$S(UCIFS:"*",1:NOCC)
  ;
  I (NICD0>0),INS D FPDAT^PXRMDGPT(DFN,.TAXARR,NGET,SDIR,BDT,EDT,"ICD0",.TLIST)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTERM.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMTERM ; SLC/PKR - Handle reminder terms. ;04/23/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMTERM ; SLC/PKR - Handle reminder terms. ;06/29/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;=============================================
@@ -19,5 +19,6 @@
  ... I 'FIEVAL(FINDING) Q
  ... S JND="@"
- ... F  S JND=$O(TFIEVAL(TFI,JND)) Q:JND=""  M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
+ ... F  S JND=$O(TFIEVAL(TFI,JND)) Q:JND=""  D
+ .... M FIEVAL(FINDING,JND)=TFIEVAL(TFI,JND)
  .. I 'FIEVAL(FINDING) Q
  .. S IND=0
@@ -79,4 +80,32 @@
  ;
  ;=============================================
+EVALPL(FINDPA,TERMARR,PLIST) ;Build a list of patients based on a
+ ;term. The list is returned in:
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,NFOUND,FILENUM)=DAS_U_DATE_U_VALUE
+ ;for findings with a start and stop date the list is
+ ;^TMP($J,PLIST,T/F,DFN,ITEM,NFOUND,FILENUM)=DAS_U_START_U_STOP_U_VALUE
+ N ENODE
+ K ^TMP($J,PLIST)
+ S ENODE=""
+ F  S ENODE=$O(TERMARR("E",ENODE)) Q:ENODE=""  D
+ . I ENODE="AUTTEDT(" D EVALPL^PXRMEDU(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTEXAM(" D EVALPL^PXRMEXAM(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTHF(" D EVALPL^PXRMHF(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTIMM(" D EVALPL^PXRMIMM(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="AUTTSK(" D EVALPL^PXRMSKIN(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="GMRD(120.51," D EVALPL^PXRMVITL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="LAB(60," D EVALPL^PXRMLAB(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="ORD(101.43," D EVALPL^PXRMORDR(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXRMD(810.9," D EVALPL^PXRMLOCL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXD(811.2," D EVALPL^PXRMTAX(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PXRMD(811.4," D EVALPL^PXRMCF(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PS(50.605," D EVALPL^PXRMDRCL(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PSDRUG(" D EVALPL^PXRMDRUG(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="PSNDF(50.6," D EVALPL^PXRMDGEN(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="RAMIS(71," D EVALPL^PXRMRAD(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ . I ENODE="YTT(601," D EVALPL^PXRMMH(.FINDPA,ENODE,.TERMARR,PLIST) Q
+ Q
+ ;
+ ;=============================================
 EVALTERM(DFN,FINDPA,TERMARR,TFIEVAL) ;Evaluate all the findings in
  ;a term. Use the "E" cross-reference just like the finding evaluation.
@@ -102,5 +131,5 @@
  . I ENODE="PSNDF(50.6," D EVALTERM^PXRMDGEN(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
  . I ENODE="RAMIS(71," D EVALTERM^PXRMRAD(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
- . I ENODE="YTT(601.71," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
+ . I ENODE="YTT(601," D EVALTERM^PXRMMH(DFN,.FINDPA,ENODE,.TERMARR,.TFIEVAL) Q
  Q
  ;
@@ -140,5 +169,9 @@
  ;=============================================
 OPT(INDENT,IFIEVAL,NLINES,TEXT,TYPE) ;General output.
- N DG,DGL,DGN,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
+ N DG,DGL,DGN,DRUG,IEN,IND,JND,KND,INDENTT,FILENUM,TEMP,TIFIEVAL
+ ;If there is a drug make it available for display.
+ S DRUG=$S($D(IFIEVAL("DISPENSE DRUG")):IFIEVAL("DISPENSE DRUG"),1:"")
+ ;DBIA #10043
+ I DRUG'="" S DRUG=$P(^PSDRUG(DRUG,0),U,1)
  ;Build the display grouping.
  S FILENUM=IFIEVAL(1,"FILE NUMBER")
@@ -164,4 +197,5 @@
  .. I KND=1 M TIFIEVAL=IFIEVAL(JND)
  .. M TIFIEVAL(KND)=IFIEVAL(JND)
+ .. I DRUG'="" S TIFIEVAL("DISPENSE DRUG")=DRUG
  . I TYPE="CM" D FOUT^PXRMOUTC(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
  . I TYPE="MHV" D FOUT^PXRMOUTM(INDENTT,.TIFIEVAL,.NLINES,.TEXT)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTEXT.m	(revision 636)
@@ -1,6 +1,6 @@
-PXRMTEXT ; SLC/PKR - Text formatting utility routines. ;07/19/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMTEXT ; SLC/PKR - Text formatting utility routines. ;11/03/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
- ;============================================
+ ;================================================================
 NEWLINE ;Put TEXT on a new line to the output, make sure it does not end
  ;with a " ".
@@ -14,5 +14,5 @@
  Q
  ;
- ;============================================
+ ;================================================================
 BLANK ;Add a blank line (line containing just " ") to the output.
  S NOUT=NOUT+1,TEXTOUT(NOUT)=" "
@@ -20,5 +20,5 @@
  Q
  ;
- ;============================================
+ ;================================================================
 CHECKLEN(WORD) ;Check to see if adding the next word makes the line too long.
  ;If it does add it to the output and start a new line.
@@ -34,83 +34,5 @@
  Q
  ;
- ;============================================
-COLFMT(FMTSTR,TEXTSTR,PC,NL,OUTPUT) ;Columnar text formatter.
- ;FMTSTR - format string; ^ separated string for each column in the
- ;output. 35R2 defines a right justified column 35 characters wide
- ;with 2 blank spaces following. Columns can be centered (C) left
- ;justified (L) or right justified (R).
- ;TEXTSTR - string to be formated
- ;PC - the pad character
- ;NL - number of lines of output
- ;OUTPUT - array containing output lines.
- N COLOUT,ENTRY,FMT,JND,JUS,IND,LEN,NCOL,NLO,NROW,SP,TEMP,TEXT,WIDTH,WPSP
- S NCOL=$L(FMTSTR,U),NROW=1
- F IND=1:1:NCOL D
- . S FMT=$P(FMTSTR,U,IND)
- . S JUS(IND)=$S(FMT["C":"C",FMT["L":"L",FMT["R":"R",1:"C")
- . S WIDTH(IND)=$P(FMT,JUS(IND),1)
- . S SP(IND)=$P(FMT,JUS(IND),2)
- . S WPSP(IND)=WIDTH(IND)+SP(IND)
- F IND=1:1:NCOL D
- . S ENTRY=$S(JUS(IND)="C":"CJ",JUS(IND)="L":"LJ",JUS(IND)="R":"RJ")
- . S TEMP=$P(TEXTSTR,U,IND)
- . S LEN=$L(TEMP)
- . I LEN'>WIDTH(IND) D
- .. S TEMP=$$@ENTRY^XLFSTR(TEMP,WIDTH(IND),PC)
- .. S COLOUT(1,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
- . I LEN>WIDTH(IND) D
- .. D FORMATS(1,WIDTH(IND),TEMP,.NLO,.TEXTOUT)
- .. F JND=1:1:NLO D
- ... S TEMP=$$@ENTRY^XLFSTR(TEXTOUT(JND),WIDTH(IND),PC)
- ... S COLOUT(JND,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
- .. I NLO>NROW S NROW=NLO
- F IND=1:1:NROW D
- . S TEXT=""
- . F JND=1:1:NCOL D
- .. I $D(COLOUT(IND,JND)) S TEXT=TEXT_COLOUT(IND,JND)
- .. E  S TEXT=TEXT_$$LJ^XLFSTR("",(WPSP(JND))," ")
- . S OUTPUT(IND)=TEXT
- S NL=NROW
- Q
- ;
- ;============================================
-COLFMTA(FMTSTR,INPUT,PC,NL,OUTPUT) ;Columnar text formatter.
- ;Array version of COLFMT. Input array is ^TMP($J,INPUT,M) and
- ;output is ^TMP(OUTPUT,$J,N,0).
- N COLOUT,ENTRY,FMT,JND,JUS,IND,LEN,NCOL,NLO,NROW,NUM
- N SP,TEMP,TEXT,WIDTH,WPSP
- S NCOL=$L(FMTSTR,U)
- F IND=1:1:NCOL D
- . S FMT=$P(FMTSTR,U,IND)
- . S JUS(IND)=$S(FMT["C":"C",FMT["L":"L",FMT["R":"R",1:"C")
- . S WIDTH(IND)=$P(FMT,JUS(IND),1)
- . S SP(IND)=$P(FMT,JUS(IND),2)
- . S WPSP(IND)=WIDTH(IND)+SP(IND)
- S NL=0,NUM=""
- F  S NUM=$O(^TMP($J,INPUT,NUM)) Q:NUM=""  D
- . K COLOUT
- . S NROW=1
- . F IND=1:1:NCOL D
- .. S ENTRY=$S(JUS(IND)="C":"CJ",JUS(IND)="L":"LJ",JUS(IND)="R":"RJ")
- .. S TEMP=$P(^TMP($J,INPUT,NUM),U,IND)
- .. S LEN=$L(TEMP)
- .. I LEN'>WIDTH(IND) D
- ... S TEMP=$$@ENTRY^XLFSTR(TEMP,WIDTH(IND),PC)
- ... S COLOUT(1,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
- .. I LEN>WIDTH(IND) D
- ... D FORMATS(1,WIDTH(IND),TEMP,.NLO,.TEXTOUT)
- ... F JND=1:1:NLO D
- .... S TEMP=$$@ENTRY^XLFSTR(TEXTOUT(JND),WIDTH(IND),PC)
- .... S COLOUT(JND,IND)=TEMP_$$LJ^XLFSTR("",SP(IND)," ")
- ... I NLO>NROW S NROW=NLO
- . F IND=1:1:NROW D
- .. S TEXT=""
- .. F JND=1:1:NCOL D
- ... I $D(COLOUT(IND,JND)) S TEXT=TEXT_COLOUT(IND,JND)
- ... E  S TEXT=TEXT_$$LJ^XLFSTR("",(WPSP(JND))," ")
- .. S NL=NL+1,^TMP(OUTPUT,$J,NL,0)=TEXT
- Q
- ;
- ;============================================
+ ;================================================================
 FORMAT(LM,RM,NIN,TEXTIN,NOUT,TEXTOUT) ;Format the text in TEXTIN so it has
  ;a left margin of LM and a right margin of RM. The formatted text
@@ -163,5 +85,5 @@
  Q
  ;
- ;============================================
+ ;================================================================
 FORMATS(LM,RM,TEXTLINE,NOUT,TEXTOUT) ;Take a single line of input text
  ;and format it.
@@ -171,31 +93,2 @@
  Q
  ;
- ;============================================
-LMFMTSTR(VALMDDF,JSTR) ;The List Manager variable VALMDDF contains the
- ;list template caption column formatting information. It contains
- ;the starting column and the width if the form
- ;VALMDDF(COLUMN NAME)=COLUMN NAME^COLUMN^WIDTH^CAPTION^VIDEO^SCROLL
- ;LOCK. JUSSTR, which is optional,is the justification for each column;
- ;(L=left, C=center, R=right) the default is center. Use this information
- ;to build the format string for the column formatter COLFMT.
- N CN,COL,FMTSTR,IND,JC,JUSSTR,PLCOL,SCOL,SP,TEMP,WIDTH
- ;Sort by columns
- S IND=""
- F  S IND=$O(VALMDDF(IND)) Q:IND=""  D
- . S TEMP=VALMDDF(IND)
- . S COL($P(TEMP,U,2))=$P(TEMP,U,3)
- S JUSSTR=$G(JSTR)
- S (CN,PLCOL,SCOL,SP)=0
- S FMTSTR=""
- S SCOL=0
- F  S SCOL=$O(COL(SCOL)) Q:SCOL=""  D
- . S CN=CN+1
- . S WIDTH=COL(SCOL)
- . I CN=1 S PLCOL=WIDTH
- . E  S SP=SCOL-PLCOL-1,FMTSTR=FMTSTR_SP_U,PLCOL=SCOL+WIDTH-1
- . S JC=$E(JUSSTR,CN)
- . I JC="" S JC="C"
- . S TEMP=WIDTH_JC
- . S FMTSTR=FMTSTR_TEMP
- Q FMTSTR
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMTMED.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;04/18/2007
- ;;2.0;CLINICAL REMINDERS;**1,4,6**;Feb 04, 2005;Build 123
+PXRMTMED ; SLC/PKR/PJH - Edit a reminder term. ;01/30/2006
+ ;;2.0;CLINICAL REMINDERS;**1,4**;Feb 04, 2005;Build 21
  ;
  ;=======================================================
@@ -62,5 +62,4 @@
  N CFIEN,GLOB,IEN,LIST,NODE,TERMSTAT,VF,WPIEN
  N DEF,DEF1,DEF2,STATUS
- S DIE("NO^")="OUTOK"
  S STATUS=0
  D DEF^PXRMRUTL("811.52",.DEF,.DEF1,.DEF2)
@@ -77,11 +76,10 @@
  S DA=+Y,GLOB=$P($P(Y,U,2),";",2) Q:GLOB=""
  I GLOB="PXRMD(811.4," S CFIEN=$P($P(Y,U,2),";",1) D
- . I $D(^PXRMD(811.4,CFIEN,1))>0 D
- .. W !!,"Computed Finding Description:" S WPIEN=0
- .. F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
- ... W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
- . E  W !!,"No description defined for this computed finding"
- . W !
- I GLOB="YTT(601.71," D WARN^PXRMMH
+ .I $D(^PXRMD(811.4,CFIEN,1))>0 D
+ ..W !!,"Computed Finding Description:" S WPIEN=0
+ ..F  S WPIEN=$O(^PXRMD(811.4,CFIEN,1,WPIEN)) Q:+WPIEN'>0  D
+ ...W !,$G(^PXRMD(811.4,CFIEN,1,WPIEN,0))
+ .E  W !!,"No description defined for this computed finding"
+ .W !
  W !,"Editing Finding Number: "_$G(DA)
  ;Finding record fields
@@ -99,5 +97,5 @@
  I VF S DR=DR_";28"
  ;Mental Health - scale
- I GLOB="YTT(601.71," S DR=DR_";13"
+ I GLOB="YTT(601," S DR=DR_";13"
  ;Radiology procedure
  I GLOB="RAMIS(71," S STATUS=1
@@ -111,5 +109,5 @@
  ;Edit finding record
  D ^DIE
- I STATUS=1,$D(DA)>0,$D(Y)=0 D STATUS^PXRMSTA1(.DA,"T")
+ I STATUS=1,$D(DA)>0 D STATUS^PXRMSTA1(.DA,"T")
  S $P(^PXRMD(811.5,IEN,20,0),U,3)=0
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMUTIL.m	(revision 636)
@@ -1,6 +1,6 @@
-PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;10/02/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
- ;
- ;=================================
+PXRMUTIL ; SLC/PKR/PJH - Utility routines for use by PXRM. ;05/25/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
+ ;
+ ;===========================================================
 ATTVALUE(STRING,ATTR,SEP,AVSEP) ;STRING contains a list of attribute value
  ;pairs. Each pair is separated by SEP and the attribute value pair
@@ -14,33 +14,5 @@
  Q VALUE
  ;
- ;=================================
-ACOPY(REF,OUTPUT) ;Copy all the descendants of the array reference into a linear
- ;array. REF is the starting array reference, for example A or
- ;^TMP("PXRM",$J). OUTPUT is the linear array for the output. It
- ;should be in the form of a closed root, i.e., A() or ^TMP($J,).
- ;Note OUTPUT cannot be used as the name of the output array.
- N DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
- I REF="" Q
- S NL=0
- S OROOT=$P(OUTPUT,")",1)
- S PROOT=$P(REF,")",1)
- ;Build the root so we can tell when we are done.
- S TEMP=$NA(@REF)
- S ROOT=$P(TEMP,")",1)
- S REF=$Q(@REF)
- I REF'[ROOT Q
- S DONE=0
- F  Q:(REF="")!(DONE)  D
- . S START=$F(REF,ROOT)
- . S LEN=$L(REF)
- . S IND=$E(REF,START,LEN)
- . S NL=NL+1
- . S OUT=OROOT_NL_")"
- . S @OUT=PROOT_IND_"="_@REF
- . S REF=$Q(@REF)
- . I REF'[ROOT S DONE=1
- Q
- ;
- ;=================================
+ ;===========================================================
 AWRITE(REF) ;Write all the descendants of the array reference.
  ;REF is the starting array reference, for example A or ^TMP("PXRM",$J).
@@ -63,5 +35,5 @@
  Q
  ;
- ;=================================
+ ;===========================================================
 DIP(VAR,IEN,PXRMROOT,FLDS) ;Do general inquiry for IEN return formatted
  ;output in VAR. VAR can be either a local variable or a global.
@@ -113,9 +85,9 @@
  Q
  ;
- ;=================================
+ ;===========================================================
 FNFR(ROOT) ;Given the root of a file return the file number.
  Q +$P(@(ROOT_"0)"),U,2)
  ;
- ;=================================
+ ;===========================================================
 NTOAN(NUMBER) ;Given an integer N return an alphabetic string that can be
  ;used for sorting. This will be modulus 26. For example N=0 returns
@@ -140,18 +112,5 @@
  Q ANUM
  ;
- ;=================================
-RMEHIST(FILENUM,IEN) ;Remove the edit history for a reminder file.
- I (FILENUM<800)!(FILENUM>811.9)!(FILENUM=811.8) Q
- N DA,DIK,GLOBAL,ROOT
- S GLOBAL=$$GET1^DID(FILENUM,"","","GLOBAL NAME")
- ;Edit History is stored in node 110 for all files.
- S DA(1)=IEN
- S DIK=GLOBAL_IEN_",110,"
- S ROOT=GLOBAL_IEN_",110,DA)"
- S DA=0
- F  S DA=+$O(@ROOT) Q:DA=0  D ^DIK
- Q
- ;
- ;=================================
+ ;===========================================================
 SEHIST(FILENUM,ROOT,IEN) ;Set the edit date and edit by and prompt the
  ;user for the edit comment.
@@ -186,5 +145,5 @@
  Q
  ;
- ;=================================
+ ;===========================================================
 SFRES(SDIR,NRES,FIEVAL) ;Save the finding result.
  I NRES=0 S FIEVAL=0 Q
@@ -202,8 +161,8 @@
  Q
  ;
- ;=================================
+ ;===========================================================
 SSPAR(FIND0,NOCC,BDT,EDT) ;Set the finding search parameters.
  S BDT=$P(FIND0,U,8),EDT=$P(FIND0,U,11),NOCC=$P(FIND0,U,14)
- I +NOCC=0 S NOCC=1
+ I NOCC="" S NOCC=1
  ;Convert the dates to FileMan dates.
  S BDT=$S(BDT="":0,BDT=0:0,1:$$CTFMD^PXRMDATE(BDT))
@@ -212,9 +171,7 @@
  ;If EDT does not contain a time set it to the end of the day.
  I EDT'["." S EDT=EDT_".235959"
- I $G(PXRMDDOC)'=1 Q
- S ^TMP("PXRMDDOC",$J,$P(FIND0,U,1,11))=BDT_U_EDT
- Q
- ;
- ;=================================
+ Q
+ ;
+ ;===========================================================
 STRREP(STRING,TS,RS) ;Replace every occurrence of the target string (TS)
  ;in STRING with the replacement string (RS).
@@ -234,5 +191,5 @@
  Q STR
  ;
- ;=================================
+ ;===========================================================
 VEDIT(ROOT,IEN) ;This is used as a DIC("S") screen to select which entries
  ;a user can edit.
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVITL.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMVITL ; SLC/PKR - Handle vitals findings. ;09/20/2007
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMVITL ; SLC/PKR - Handle vitals findings. ;10/21/2004
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;===========================================================
@@ -20,18 +20,13 @@
  ;
  ;===========================================================
-GETDATA(DAS,FIEVT) ;Return data for a GMRV Vital Measurement entry.
- N EM,IND,GMRVDATA,STOP,TEMP,TYPE
+GETDATA(DAS,FIEVT) ;Return the value, which is Rate, for a specified
+ ;GMRV Vital Measurement entry.
+ N IND,GMRVDATA,TEMP
  ;DBIA #3647
  D EN^GMVPXRM(.GMRVDATA,DAS,"I")
  I $P(GMRVDATA(1),U,1)=-1 D  Q
- . S ^TMP("PXRMXMZ",$J,1,0)="Found GMRV entry "_DAS_" in the index, but it does not exist in ^GMR(120.5"
+ . S ^TMP("PXRMXMZ",$J,1,0)="Found GMRV entry "_DAS_" in the index, but it does not exist in ^GMRV(120.5"
  . D SEND^PXRMMSG("Bad entry in Vitals index.")
- S FIEVT("TYPE")=$$EXTERNAL^DILFD(120.5,.03,"",GMRVDATA(3),.EM)
- ;DBIA #10040
- S TEMP=$S(+GMRVDATA(5)'=0:^SC(GMRVDATA(5),0),1:"")
- S FIEVT("HOSPITAL LOCATION")=$P(TEMP,U,1)
- S FIEVT("LOCATION TYPE")=$P(TEMP,U,3)
- S STOP=$P(TEMP,U,7)
- S FIEVT("ENTERED BY")=$P(^VA(200,GMRVDATA(6),0),U,1)
+ S FIEVT("TYPE")=$P(GMRVDATA(3),U,1)
  S (FIEVT("RATE"),FIEVT("VALUE"))=$P(GMRVDATA(7),U,1)
  S IND=0
@@ -41,7 +36,4 @@
  .;DBIA #4504
  . I TEMP'="" S FIEVT("QUALIFIER",IND)=$P($G(^GMRD(120.52,+TEMP,0)),U,1)
- ;DBIA #557
- I STOP'="" S FIEVT("STOP CODE")=$P(^DIC(40.7,STOP,0),U,1,2)
- E  S FIEVT("STOP CODE")=""
  Q
  ;
@@ -66,6 +58,7 @@
  ;maintenance output.
  N DATE,EM,IND,JND,NOUT,RATE,TEMP,TEXTOUT,TYPE
+ S TYPE=$$EXTERNAL^DILFD(120.5,.03,"",IFIEVAL("TYPE"),.EM)
  S NLINES=NLINES+1
- S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_IFIEVAL("TYPE")
+ S TEXT(NLINES)=$$INSCHR^PXRMEXLC(INDENT," ")_"Vital Measurement: "_TYPE
  S IND=0
  F  S IND=+$O(IFIEVAL(IND)) Q:IND=0  D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVPTR.m	(revision 636)
@@ -1,4 +1,4 @@
 PXRMVPTR ; SLC/PKR - Routines for dealing with variable pointers. ; 02/06/2001
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ;
  ;==================================================
@@ -20,5 +20,4 @@
  ;indexed by the file number.
  N FN,IND,ROOT,TEMP
- ;DBIA #2991
  S IND=0
  F  S IND=$O(^DD(FILE,FIELD,"V",IND)) Q:+IND=0  D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMVSIT.m	(revision 636)
@@ -1,38 +1,29 @@
-PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;02/22/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMVSIT ; SLC/PKR - Visit related info for reminders. ;07/06/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;======================================================
-GETDATA(DA,DATA,SVALUE) ;Return data for a specific Visit file entry.
+GETDATA(DA,FIEVT,SVALUE) ;Return data for a specific Visit file entry.
  ;DBIA #2028 for Visit file.
- N DONE,IEN,HTEMP,LOE,TEMP
+ N HTEMP,TEMP
  S TEMP=^AUPNVSIT(DA,0)
- S DATA("VISIT")=DA
- S DATA("DATE VISIT CREATED")=$P(TEMP,U,2)
- S DATA("DFN")=$P(TEMP,U,5)
- S (DATA("LOC. OF ENCOUNTER"),LOE)=$P(TEMP,U,6)
- ;DBIA #10090
- S DATA("STATION NUMBER")=$$GET1^DIQ(4,LOE,99)
- S DATA("OFFICAL VA NAME")=$$GET1^DIQ(4,LOE,100)
- S DATA("SERVICE CATEGORY")=$P(TEMP,U,7)
- I $G(SVALUE) S DATA("VALUE")=$P(TEMP,U,7)
- S DATA("HOSPITAL LOCATION")=$P(TEMP,U,22)
+ S FIEVT("VISIT")=DA
+ S FIEVT("DATE VISIT CREATED")=$P(TEMP,U,2)
+ S FIEVT("DFN")=$P(TEMP,U,5)
+ S FIEVT("LOC. OF ENCOUNTER")=$P(TEMP,U,6)
+ S FIEVT("SERVICE CATEGORY")=$P(TEMP,U,7)
+ I $G(SVALUE) S FIEVT("VALUE")=$P(TEMP,U,7)
+ S FIEVT("HOSPITAL LOCATION")=$P(TEMP,U,22)
  ;DBIA #10040, #2804
- I $G(DATA("HOSPITAL LOCATION"))="" S HTEMP=""
- E  S HTEMP=^SC(DATA("HOSPITAL LOCATION"),0)
- S DATA("HLOC")=$P(HTEMP,U,1)
- S DATA("DSS ID")=$P(TEMP,U,8)
- I DATA("DSS ID")="" S DATA("DSS ID")=$P(HTEMP,U,7)
+ I $G(FIEVT("HOSPITAL LOCATION"))="" S HTEMP=""
+ E  S HTEMP=^SC(FIEVT("HOSPITAL LOCATION"),0)
+ S FIEVT("HLOC")=$P(HTEMP,U,1)
+ S FIEVT("DSS ID")=$P(TEMP,U,8)
+ I FIEVT("DSS ID")="" S FIEVT("DSS ID")=$P(HTEMP,U,7)
  ;DBIA #557
- I DATA("DSS ID")'="" S DATA("STOP CODE")=$P(^DIC(40.7,DATA("DSS ID"),0),U,2)
- S DATA("OUTSIDE LOCATION")=$G(^AUPNVSIT(DA,21))
- S DATA("COMMENTS")=$G(^AUPNVSIT(DA,811))
+ I FIEVT("DSS ID")'="" S FIEVT("STOP CODE")=$P(^DIC(40.7,FIEVT("DSS ID"),0),U,2)
+ S FIEVT("OUTSIDE LOCATION")=$G(^AUPNVSIT(DA,21))
+ S FIEVT("COMMENTS")=$G(^AUPNVSIT(DA,811))
  ;DBIA #4850
- S DATA("STATUS")=$$STATUS^SDPCE(DA)
- ;Get the primary provider.
- ;DBIA #3455 for V PROVIDER
- S DATA("PRIMARY PROVIDER")="",IEN="",DONE=0
- F  S IEN=$O(^AUPNVPRV("AD",DA,IEN)) Q:(DONE)!(IEN="")  D
- . S TEMP=^AUPNVPRV(IEN,0)
- . I $P(TEMP,U,4)="P" S DATA("PRIMARY PROVIDER")=$P(TEMP,U,1),DONE=1
+ S FIEVT("STATUS")=$$STATUS^SDPCE(DA)
  Q
  ;
@@ -89,9 +80,8 @@
  ;NO-SHOW
  ;NO-SHOW & AUTO RE-BOOK
- ;NULL
  N STATUS,VALID
  ;DBIA #4850
  S STATUS=$P($$STATUS^SDPCE(VIEN),U,2)
- S VALID=$S(STATUS["CANCELLED":0,STATUS["DELETED":0,STATUS["NO ACTION":0,STATUS["NO-SHOW":0,STATUS="":0,1:1)
+ S VALID=$S(STATUS["CANCELLED":0,STATUS["DELETED":0,STATUS["NO ACTION":0,STATUS["NO-SHOW":0,1:1)
  Q VALID
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXD.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXD ; SLC/PJH - Reminder Due reports DRIVER ;11/27/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXD ; SLC/PJH - Reminder Due reports DRIVER ;06/20/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 START ; Arrays and strings
@@ -17,5 +17,5 @@
  N DBDOWN,DBDUZ,DBERR,PXRMLIST,PXRMLIS1,Y
  N PLISTPUG
- N PXRMTPAT,PXRMDPAT,PXRMPML
+ N PXRMTPAT,PXRMDPAT
  ;
  S PXRMRT="PXRMX",PXRMTYP="X",PXRMFCMB="N",PXRMLCMB="N",PXRMTCMB="N"
@@ -153,17 +153,8 @@
  .D LIT,TOTALS^PXRMXSD(.PXRMTOT,LIT1,LIT2,LIT3)
  ;
-MLOC     ;Print Locations empty location at the end of the report
- W !
- S DIR(0)="Y",DIR("B")="YES",DIR("A")="Print locations with no patients"
- D ^DIR
- I Y="^^" G EXIT
- I Y=U G:PXRMREP="D" SSN G TOT
- S PXRMPML=Y
- ;
  ;Reminder Category/Individual Reminder Selection
 RCAT ;
  D RCAT^PXRMXSU(.PXRMRCAT,.PXRMREM) I $D(DTOUT) G EXIT
- ;I $D(DUOUT) G:PXRMREP="D" SSN G TOT
- I $D(DUOUT) G MLOC
+ I $D(DUOUT) G:PXRMREP="D" SSN G TOT
  ;
  ;Create combined reminder list
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXDT1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;08/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXDT1 ; SLC/PJH - Build Patient list SUBROUTINES;07/10/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ; Called by label from PXRMXSEO,PXRMXSE
@@ -167,5 +167,5 @@
  Q
  ;
-ERRMSG(TYPE) ;
+DBDOWN(TYPE) ;
  N CNT,CNT1,CNT2,STR,NLINES,OUTPUT,TIME
  K ^TMP("PXRMXMZ",$J)
@@ -173,5 +173,5 @@
  I TYPE="C" D  Q
  .M ^TMP("PXRMXMZ",$J)=^TMP($J,"PXRM CNBD")
- .D SEND^PXRMMSG("REMINDER REPORTS CNBD PATIENT LIST ("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
+ .D SEND^PXRMMSG("COULD NOT BE DETERMINED PATIENTS("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
  I 'PXRMQUE D
  .S STR(1)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
@@ -180,7 +180,7 @@
  .F CNT=1:1:NLINES W !,OUTPUT(CNT)
  I PXRMQUE D
- .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_"was cancelled for the following reason(s):"
+ .S ^TMP("PXRMXMZ",$J,1,0)="The Reminders Due Report "_$G(TITLE)_" requested by "_$$GET1^DIQ(200,DUZ,.01)_" on "_$$FMTE^XLFDT($G(PXRMXST))_" for the following reason(s):"
  .F  S CNT=$O(DBERR(CNT)) Q:CNT'>0  S ^TMP("PXRMXMZ",$J,CNT1,0)=DBERR(CNT),CNT1=CNT1+1
- .D SEND^PXRMMSG("Cancelled Reminders Due Report ("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
+ .D SEND^PXRMMSG("Cancelled Reminders Due Report("_$$FMTE^XLFDT($$NOW^XLFDT)_")",1)
  .S ZTSTOP=1
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXGPR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXGPR ; SLC/PJH - Reminder Due print calls ;11/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXGPR ; SLC/PJH - Reminder Due print calls ;01/09/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Called from PXRMXPR
@@ -174,5 +174,5 @@
  ;
  ;form feed to new page
-PAGE I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D
+PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
  .S DIR(0)="E"
  .W !
@@ -181,5 +181,5 @@
  W:$D(IOF)&(PAGE>0) @IOF
  S PAGE=PAGE+1,FIRST=0
- I $E(IOST,1,2)="C-",IO=IO(0) W @IOF
+ I $E(IOST)="C",IO=IO(0) W @IOF
  E  W !
  N TEMP,TEXTLEN
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXGUT.m	(revision 636)
@@ -1,8 +1,8 @@
-PXRMXGUT ; SLC/PJH - General utilities for reminder reports; 11/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXGUT ; SLC/PJH - General utilities for reminder reports; 05/31/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;=======================================
 EOR ;End of report display.
- I $E(IOST,1,2)="C-",IO=IO(0) D
+ I $E(IOST)="C",IO=IO(0) D
  . S DIR(0)="EA"
  . S DIR("A")="End of the report. Press ENTER/RETURN to continue..."
@@ -29,10 +29,24 @@
  ;
  ;=======================================
-TIMING ;Print report timing data.
- N IND
- W !!,"Report timing data:"
- S IND=""
- F  S IND=$O(^XTMP(PXRMXTMP,"TIMING",IND)) Q:IND=""  W !," ",^XTMP(PXRMXTMP,"TIMING",IND)
- Q
+VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
+ ;SLIST.  If they are, then LIST is valid.  The elements of LIST can be
+ ;separated by commas and spaces.
+ N IC,LE,LEN,VALID
+ S LIST=$TR(LIST,",","")
+ S LIST=$TR(LIST," ","")
+ ;Make the test case insensitive.
+ S SLIST=$$UP^XLFSTR(SLIST)
+ S LIST=$$UP^XLFSTR(LIST)
+ S VALID=1
+ S LEN=$L(LIST)
+ I LEN=0 D
+ . W !,"The list is empty!"
+ . S VALID=0
+ F IC=1:1:LEN D
+ . S LE=$E(LIST,IC,IC)
+ . I SLIST'[LE D
+ .. W !,LE,MESSAGE
+ .. S VALID=0
+ Q VALID
  ;
  ;=======================================
@@ -75,24 +89,2 @@
  Q STR
  ;
- ;=======================================
-VLIST(SLIST,LIST,MESSAGE) ;Make sure all the elements of LIST are in
- ;SLIST.  If they are, then LIST is valid.  The elements of LIST can be
- ;separated by commas and spaces.
- N IC,LE,LEN,VALID
- S LIST=$TR(LIST,",","")
- S LIST=$TR(LIST," ","")
- ;Make the test case insensitive.
- S SLIST=$$UP^XLFSTR(SLIST)
- S LIST=$$UP^XLFSTR(LIST)
- S VALID=1
- S LEN=$L(LIST)
- I LEN=0 D
- . W !,"The list is empty!"
- . S VALID=0
- F IC=1:1:LEN D
- . S LE=$E(LIST,IC,IC)
- . I SLIST'[LE D
- .. W !,LE,MESSAGE
- .. S VALID=0
- Q VALID
- ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXPR.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXPR ; SLC/PJH - Print Reminder Due report. ;11/27/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXPR ; SLC/PJH - Print Reminder Due report. ;01/14/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ; Called/Jobbed after PXRMXSE1
@@ -135,5 +135,5 @@
  I ('DONE),$O(^XTMP(PXRMXTMP,PX,""))="" D NULL^PXRMXGPR G EXIT
  ; Report selected patient sample with no patients
- I $D(MISSED),PXRMPML=1 D MISSED^PXRMXPR1(0,.MISSED)
+ I $D(MISSED) D MISSED^PXRMXPR1(0,.MISSED)
  ;
  ;Print Patient List
@@ -143,5 +143,4 @@
  I $D(^XTMP(PXRMXTMP,"ERROR"))>0!($D(^XTMP(PXRMXTMP,"CNBD"))>0) D ERROR^PXRMXBSY
 EXIT ;
- D TIMING^PXRMXGUT
  D EXIT^PXRMXGUT
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXPR1.m	(revision 636)
@@ -1,4 +1,4 @@
 PXRMXPR1 ; SLC/AGP - Print Reminder Due report carryover code. ;01/05/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ;Patient list display
@@ -70,5 +70,5 @@
  N DATA,IC,LTYPE,MARK
  S IC=""
- I PXRMSEL="P" D  Q
+ I PXRMSEL="P" D
  . F  S IC=$O(PXRMPRV(IC)) Q:IC=""  D
  .. S DATA=PXRMPRV(IC)
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXQUE.m	(revision 636)
@@ -1,6 +1,6 @@
-PXRMXQUE ; SLC/PJH - Reminder reports general queuing routine.;03/23/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXQUE ; SLC/PJH - Reminder reports general queuing routine.;02/24/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
- ;Determine whether the report should be queued.
+        ;Determine whether the report should be queued.
 JOB ;
  N %ZIS S %ZIS="Q"
@@ -42,11 +42,10 @@
  Q $G(ZTSK)
  ;
-DEVICE(RTN,DESC,SAVE,%ZIS,RETZTSK) ;
- ;Pass RETZTSK as number such as 1 if you want to get ZTSK.
- N ZTSK
+DEVICE(ZTRTN,ZTDESC,ZTSAVE,%ZIS,ZTSK) ;
  W !
- D EN^XUTMDEVQ(RTN,DESC,.SAVE,.%ZIS,RETZTSK)
- I $D(ZTSK) W !!,DESC," has been queued, task number "_ZTSK H 2
- Q $G(ZTSK)
+ D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,.%ZIS,.ZTSK)
+ I $D(ZTSK)>1 W !!,ZTDESC," has been queued, task number "_$G(ZTSK) H 2
+ I $G(ZTSK)="" S ZTSK=0
+ Q ZTSK
  ;
  ;=======================================================================
@@ -138,4 +137,3 @@
  S ZTSAVE("PXRMDPAT")=""
  I +$G(PXRMIDOD)>0 S ZTSAVE("PXRMIDOD")=""
- S ZTSAVE("PXRMPML")=""
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSC.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXSC ; SLC/PJH - Reminder reports service category selection ;12/18/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSC ; SLC/PJH - Reminder reports service category selection ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 SCAT ;Get the list of service categories.
@@ -10,5 +10,14 @@
  D HELP^DIE(9000010,"",.07,"S","SCA")
  S NSC=SCA("DIHELP")
- S DIR("?")=U_"D SCATHELP^PXRMXSC"
+ S DIR("?")=" "
+ S DIR("?",1)="The possible service categories for the report are:"
+ S JC=0
+ F IC=2:1:NSC D
+ . S X=$P(SCA("DIHELP",IC)," ",1)
+ . I PCESVC="" S PCESVC=X
+ . E  S PCESVC=PCESVC_","_X
+ . S JC=JC+1
+ . S DIR("?",JC)=SCA("DIHELP",IC)
+ S NSC=JC
  S DIR("??")=U_"D SCATHELP^PXRMXSC"
 SCATP ;
@@ -28,23 +37,9 @@
  ;
  ;======================================================
-SCATHELP ;? help for service categories.
- N ARRAY,IC,JC,NSC,PCESVC
- S PCESVC=""
- D HELP^DIE(9000010,"",.07,"S","SCA")
- S NSC=SCA("DIHELP")
- S JC=0
- F IC=2:1:NSC D
- . S X=$P(SCA("DIHELP",IC)," ",1)
- . I PCESVC="" S PCESVC=X
- . E  S PCESVC=PCESVC_","_X
- . S JC=JC+1
- . S ARRAY(JC)=SCA("DIHELP",IC)
- S NSC=JC
+SCATHELP ;?? help for service categories.
  W !!,"Enter the letter(s), separated by commas, corresponding to the desired service"
  W !,"category or categories. For example A,H,T,E would allow only encounters with"
  W !,"service categories of ambulatory, hospitalization, telecommunications, and"
  W !,"event (historical) to be included."
- W !!,"The possible service categories for the report are:",!
- F IC=1:1:NSC W !,ARRAY(IC)
  Q
  ;
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSE1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 08/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSE1 ; SLC/PJH - Build Patient lists for Reminder Due report; 01/25/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ; Called/jobbed from PXRMXD
@@ -64,5 +64,5 @@
  ..N DA,DIK S DA=PXRMLIS1,DIK="^PXRMXP(810.5," D ^DIK
  .;Otherwise create patient list
- .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","","",PXRMDPAT,PXRMTPAT)
+ .D UPDLST^PXRMRULE("PXRMXPAT",PXRMLIS1,"","")
  .S $P(^PXRMXP(810.5,PXRMLIS1,0),U,9)=1
  K ^TMP($J,"PXRMXPAT")
@@ -152,6 +152,5 @@
  ;
 XTMP(START) ;
- N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME
- N SUB,STATUS,TEMP,TEMP1,TEXT
+ N CNT,CCNT,DDAT,INP,ITEM,LIT,LSSN,MCNBD,MCNBDR,NAME,SUB,STATUS,TEMP,TEMP1
  K ^TMP($J,"PXRM CNBD")
  S CCNT=0,MCNBD=$G(^PXRM(800,1,"MIERR")),MCNBDR=0
@@ -189,10 +188,8 @@
  ....I PXRMREP="D" D SDET^PXRMXDT1(DFN,STATUS,NAM,FACILITY,INP)
  ....I PXRMREP="S" D SUM^PXRMXDT1(DFN,STATUS,FACILITY,NAM)
- I $D(^TMP($J,"PXRM CNBD"))>0 D ERRMSG^PXRMXDT1("C")
+ I $D(^TMP($J,"PXRM CNBD"))>0 D DBDOWN^PXRMXDT1("C")
  K ^TMP($J,"PXRM CNBD")
  S END=$H
- S TEXT="Elapsed time for reminder evaluation: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","REMINDER EVALUATION")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Evaluating Reminders")
  ;I PXRMDBUG="Y" D DEBUG("DEBUG PATIENT DATA EVALUATION","DEBUG","^TMP($J,""PXRMDEBUG"")")
  K ^TMP($J,"PXRM PATIENT EVAL")
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSL1.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXSL1 ; SLC/PJH - Process Visits/Appts Reminder Due report;02/07/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSL1 ; SLC/PJH - Process Visits/Appts Reminder Due report;12/09/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
  ; Called from PXRMXSE
@@ -25,14 +25,4 @@
  I '$D(PXRMFACN(HFAC)) Q ""
  Q HFAC
- ;
-INACTCL(HLIEN,PXRMBDT) ;
- ;Check to see if clinic is inactivated before the start of 
- ;the reporting period
- N INACT,REACT
- S INACT=+$P($G(^SC(HLIEN,"I")),U) I INACT=0 Q 0
- S REACT=+$P($G(^SC(HLIEN,"I")),U,2)
- I REACT'<INACT Q 0
- I INACT<PXRMBDT Q 1
- Q 0
  ;
 INPADM ;
@@ -61,6 +51,5 @@
  ;
 BHLOC ;
- N CLINIEN,END,FACILITY,NAM,HLIEN,I,START,TEXT
- N INACT,REACT
+ N CLINIEN,END,FACILITY,NAM,HLIEN,I,START
  I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
  ;All inpatient, outpatient all location credit stop and encounter
@@ -69,5 +58,4 @@
  .S HLIEN=0 F  S HLIEN=$O(^SC(HLIEN)) Q:HLIEN'>0  D
  ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ..I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ..S NAM=$P(^SC(HLIEN,0),U)
  ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
@@ -82,5 +70,4 @@
  .S HLIEN=0 F  S HLIEN=$O(PXRMLOCN(HLIEN)) Q:HLIEN'>0  D
  ..S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ..I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ..S NAM=$P(^SC(HLIEN,0),U)
  ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
@@ -91,5 +78,4 @@
  ..S HLIEN=0 F  S HLIEN=$O(^SC("AST",CLINIEN,HLIEN)) Q:HLIEN'>0  D
  ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ...I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ...S NAM=$P(^DIC(40.7,CLINIEN,0),U)_" "_$P(PXRMCS($G(PXRMCSN(CLINIEN))),U,3)
  ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
@@ -100,22 +86,20 @@
  ..S HLIEN=0 F  S HLIEN=$O(^SC("ASCRPW",CGRPIEN,HLIEN)) Q:HLIEN'>0  D
  ...S FACILITY=$$HFAC(HLIEN) I FACILITY'>0 Q
- ...I $$INACTCL(HLIEN,PXRMBDT)=1 Q
  ...I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Building Hospital Locations List",.BUSY)
  ...S ^XTMP(PXRMXTMP,"HLOC",HLIEN)=FACILITY_U_$P(^SC(HLIEN,0),U)_U_CGRPIEN
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
  S END=$H
- S TEXT="Elapsed time for building hospital locations: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","BUILDING HOSPITAL LOCATIONS")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
- Q
- ;
-DETIME(START,END) ;
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME(START,END,"Building Hospital Locations")
+ Q
+ ;
+DETIME(START,END,SECTION) ;
  N ETIME,TEXT
  S ETIME=$$HDIFF^XLFDT(END,START,2)
  I ETIME>90 D
  . S ETIME=$$HDIFF^XLFDT(END,START,3)
- . S TEXT=ETIME
- E  S TEXT=ETIME_" secs"
- Q TEXT
+ . S TEXT="Elapsed time for "_SECTION_": "_ETIME
+ E  S TEXT="Elapsed time for "_SECTION_": "_ETIME_" secs"
+ D MES^XPDUTL(TEXT)
+ Q
  ;
 OERR ;
@@ -145,5 +129,4 @@
  I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
  N CNT,SCDT,LIST,SCERR,SCLIST,II,PCM,NAM,PNAM,PXRM,OK
- N FACILITY,NAM
  S SCDT("BEGIN")=PXRMSDT,SCDT("END")=PXRMSDT
  ;Include patient if in team on any day in range
@@ -163,8 +146,5 @@
  ..I PXRMPRIM="P",($$PCASSIGN^PXRMXAP(DFN)'=1) Q
  ..;For detailed provider report get assoc clinic
- ..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCM",CNT),U,7) I +$G(DCLN)>0 D
- ...S FACILITY=$$HFAC(DCLN)
- ...S NAM=$P(^SC(DCLN,0),U)
- ...S ^XTMP(PXRMXTMP,"HLOC",DCLN)=FACILITY_U_NAM
+ ..I PXRMREP="D" S DCLN=$P(^TMP($J,"PCM",CNT),U,7) I $G(DCLN)'="" S ^XTMP(PXRMXTMP,"HLOC",DCLN)=""
  ..I $G(DCLN)'="" S PXRMDCLN(DCLN)=""
  ..D UPD1(DFN,NAM,"FACILITY",+$G(DCLN))
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXSL2.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 08/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXSL2 ; SLC/AGP - Process Visits/Appts Reminder Due report; 06/07/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ;
 APPTS ;
@@ -6,7 +6,6 @@
  N APPTDT,BDT,EDT,NODE,DFN,FACILITY,HLIEN,NAM
  S NAM="All Locations"
- S BDT=PXRMBDT
- ;I PXRMBDT["." S BDT=PXRMBDT
- ;E  S BDT=PXRMBDT-.0001
+ I PXRMBDT["." S BDT=PXRMBDT
+ E  S BDT=PXRMBDT-.0001
  I PXRMEDT["." S EDT=PXRMEDT
  E  S EDT=PXRMEDT+.2359
@@ -41,5 +40,5 @@
  ;
 SDAM301(BD,ED,PXRMSEL,PXRMFD,PXRMREP) ;
- N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS,TEXT
+ N ARRAY,BUSY,FACILITY,NAM,OPIEN,STATUS
  K ^TMP($J,"PXRM FUTURE APPT")
  K ^TMP($J,"PXRM FACILITY FUTURE APPT")
@@ -64,7 +63,5 @@
  S COUNT=$$SDAPI^SDAMA301(.ARRAY)
  S END=$H
- S TEXT="Elapsed time for call to the Scheduling Package: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","SCHEDULING")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Total amount of time to call the Scheduling Package")
  I COUNT<0 D  Q
  .N CNT
@@ -72,9 +69,9 @@
  .F  S CNT=$O(^TMP($J,"SDAMA301",CNT)) Q:CNT'>0  D
  ..S DBERR(CNT)=$G(^TMP($J,"SDAMA301",CNT))
- .D ERRMSG^PXRMXDT1("E")
+ .D DBDOWN^PXRMXDT1("E")
  ;
 LOOP ;
  I PXRMFD'="P"!(PXRMSEL'="L") Q
- N APPTDT,CIEN,DFN,FUTDT,NODE,TEXT,VIEN
+ N APPTDT,CIEN,DFN,FUTDT,NODE,VIEN
  ;LOOP THROUGH PATIENT
  S START=$H
@@ -102,67 +99,11 @@
  S END=$H
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
- S TEXT="Elapsed time for sorting SDAMA301 output: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","SCHEDULE SORT")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Sorting SDAMA301 Output")
  Q
  ;
  ;Scan visit file to build list of patients
 VISITS ;
- N BUSY,DAS,DATE,DFN,DS,END,ETIME,HLOC,NF
- N SC,START,TEMP,TEXT,TGLIST,TIME
- S START=$H
- K ^TMP($J,"PXRM PATIENT LIST")
- I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
- W !,"Building patient list "
- K ^TMP($J,"HLOCL"),^TMP($J,"PLIST")
- M ^TMP($J,"HLOCL")=^XTMP(PXRMXTMP,"HLOC")
- D FPLIST^PXRMLOCL(9000010,"HLOCL",-1,PXRMBDT,PXRMEDT,"PLIST")
- K ^TMP($J,"HLOCL")
- S DFN=""
- F  S DFN=$O(^TMP($J,"PLIST",DFN)) Q:DFN=""  D
- . S NF=0
- . F  S NF=$O(^TMP($J,"PLIST",DFN,NF)) Q:NF=""  D
- .. S TEMP=^TMP($J,"PLIST",DFN,NF)
- .. S SC=$P(TEMP,U,4)
- .. I '$D(PXRMSCAT(SC)) Q
- .. ;Remove test Patients
- .. I 'PXRMTPAT,$$TESTPAT^VADPT(DFN)=1 Q
- .. ;Remove deceased patients
- .. I 'PXRMDPAT,$P($G(^DPT(DFN,.35)),U,1)>0 Q
- .. S DAS=$P(TEMP,U,1),DATE=$P(TEMP,U,2),HLOC=$P(TEMP,U,3)
- .. S ^TMP($J,"PXRM PATIENT LIST",DFN,HLOC,DATE,DAS)=""
- K ^TMP($J,"PLIST")
- S END=$H
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
- S TEXT="Elapsed time for building patient list: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","PATIENT LIST")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
- I PXRMREP="D" D SDAM301(PXRMBDT,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
- I DBDOWN=1 Q
- S START=$H
- S BUSY=0
- I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
- N HLIEN,NAM,FACILITY,LSEL,NODE
- S DFN=0 F  S DFN=$O(^TMP($J,"PXRM PATIENT LIST",DFN)) Q:DFN'>0  D
- .S HLIEN=0
- .F  S HLIEN=$O(^TMP($J,"PXRM PATIENT LIST",DFN,HLIEN)) Q:HLIEN'>0  D
- ..I ('(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")))&(DBDOWN=0) D SPIN^PXRMXBSY("Removing Invalid Encounter(s)",.BUSY)
- ..S NODE=$G(^XTMP(PXRMXTMP,"HLOC",HLIEN))
- ..S FACILITY=$P(NODE,U),NAM=$P(NODE,U,2)
- ..D TMP^PXRMXSL1(DFN,NAM,FACILITY,HLIEN)
- ..S TEMP=$P(PXRMLCSC,U,1)
- ..S LSEL=$S(TEMP="CS":$P(NODE,U,3),TEMP="GS":$P(NODE,U,3),1:HLIEN)
- ..D MARK^PXRMXSL1(LSEL)
- ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
- S END=$H
- S TEXT="Elapsed time for removing invalid encounter(s): "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","REMOVING INVALID ENCOUNTER(S)")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
- Q
- ;
-VISITSO ; Old entry point
  N BTIME,DAS,DATE,DEND,DFN,DONE,DS,ETIME,HLOC,INVBD,INVDATE,INVDT,INVED
- N NFOUND,SC,TEMP,TEXT,TGLIST,TIME
+ N NFOUND,SC,TEMP,TGLIST,TIME
  N DOD,START,END
  S START=$H
@@ -175,5 +116,5 @@
  S INVBD=9999999-$P(PXRMBDT,".",1),BTIME=+("."_$P(PXRMBDT,".",2))
  S INVED=9999999-$P(DEND,".",1),ETIME=+("."_$P(DEND,".",2))
- S DS=INVED-.000001
+ S DS=INVED-1
  S HLOC=""
  F  S HLOC=$O(^XTMP(PXRMXTMP,"HLOC",HLOC)) Q:HLOC=""  D
@@ -203,13 +144,11 @@
  S END=$H
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
- S TEXT="Elapsed time for building patient list: "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","PATIENT LIST")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
- I PXRMREP="D" D SDAM301(PXRMBDT,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
- ;D SDAM301(PXRMBDT-.0001,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Building Patient List")
+ D SDAM301(PXRMBDT-.0001,PXRMEDT,PXRMSEL,PXRMFD,PXRMREP)
  ;
  I DBDOWN=1 Q
  S START=$H
  S BUSY=0
+ I DBDOWN=1 Q
  N NODE
  I '(PXRMQUE!$D(IO("S"))) D INIT^PXRMXBSY(.BUSY)
@@ -227,7 +166,5 @@
  ..S ^TMP($J,"PXRM PATIENT EVAL",DFN)=""
  S END=$H
- S TEXT="Elapsed time for removing invalid encounter(s): "_$$DETIME^PXRMXSL1(START,END)
- S ^XTMP(PXRMXTMP,"TIMING","REMOVING INVALID ENCOUNTER(S)")=TEXT
- I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) W !,TEXT
  I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DONE^PXRMXBSY("Done")
+ I '(PXRMQUE!$D(IO("S"))!(PXRMTABS="Y")) D DETIME^PXRMXSL1(START,END,"Removing Invalid Encounter(s)")
  Q
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTB.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;11/27/2006
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+PXRMXTB ; SLC/PJH - Reminder Reports Template Load ;08/01/2001
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ; 
  ; Called from PXRMXD
@@ -58,5 +58,4 @@
  S XREF("PXRMLCSC")=1.5
  S XREF("PXRMFD")=1.6
- S XREF("PXRMPML")=1.7
  S XREF("PXRMREM")=2
  S XREF("PXRMFAC")=3
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTD.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/16/2007
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXTD ; SLC/PJH - Reminder Reports Template Display ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ; Called from PXRMXT/PXRMXTF
@@ -24,5 +24,4 @@
  .I $E(PXRMLCSC,2)'="A" W ! D ARRS
  I DONE Q
- W !?PSTART,"Print Locations without Patients:",?32,$S($G(PXRMPML)=0:"NO",1:"YES")
  S IC="" F  S IC=$O(PXRMRCAT(IC)) Q:IC=""  D  Q:DONE
  .W !,?PSTART W:IC=1 "Category:"
@@ -95,5 +94,5 @@
  ;form feed to new page
  ;---------------------
-PAGE I ($E(IOST,1,2)="C-")&(IO=IO(0))&(PAGE>0) D
+PAGE I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
  .S DIR(0)="E"
  .W !
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTE.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;11/27/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXTE ; SLC/PJH - Reminder Reports Template Edit ;08/03/2006
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ; Called from PXRMYD,PXRMXD
@@ -58,6 +58,4 @@
  ;Report type (detail or summary)
  S DR=DR_";1.4"
- ;Print Locations without patients
- S DR=DR_";1.7"
  ;Reminder Categories
  I $D(^PXRMPT(810.1,DA,12,0))>0 D
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTF.m	(revision 636)
@@ -1,4 +1,4 @@
 PXRMXTF ; SLC/PJH - Reminder Reports Template Filing ;05/02/2002
- ;;2.0;CLINICAL REMINDERS;**6**;Feb 04, 2005;Build 123
+ ;;2.0;CLINICAL REMINDERS;;Feb 04, 2005
  ; 
  ; Called from PXRMXTA
Index: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m
===================================================================
--- FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m	(revision 631)
+++ FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMXTU.m	(revision 636)
@@ -1,4 +1,4 @@
-PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/27/2006
- ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+PXRMXTU ; SLC/PJH - Reminder Reports Template Update ;11/03/2005
+ ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
  ; 
  ; Called from PXRMYD,PXRMXD (also at UPD from PXRMXPR/PXRMYPR)
@@ -59,5 +59,5 @@
  ;
  ;Save single fields into FDA
- F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP","PXRMPML" D
+ F IC="NAME","PXRMLCSC","PXRMPRIM","PXRMREP","PXRMSEL","PXRMTYP" D
  .S FDA(810.1,MODE,XREF(IC))=$G(@IC)
  F IC="PXRMFD","PXRMSCAT","RUN","TITLE" D
Index: FOIAVistA/tag/r/CMOP-PSX/PSXBLD1.m
===================================================================
--- FOIAVistA/trunk/r/CMOP-PSX/PSXBLD1.m	(revision 631)
+++ FOIAVistA/tag/r/CMOP-PSX/PSXBLD1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSXBLD1 ;BIR/BAB,HTW,WPB-Document Data for Transmission ;10/15/98  10:38 AM
- ;;2.0;CMOP;**3,18,19,42,41,49,57,64**;11 Apr 97;Build 1
+ ;;2.0;CMOP;**3,18,19,42,41,49,57**;11 Apr 97
  ;Reference to  ^PSRX(     supported by DBIA #1977
  ;Reference to  ^PSDRUG(   supported by DBIA #1983
@@ -88,5 +88,5 @@
  S TXT(1)="The following Pharmacy Site instruction(s) exceed seven lines."
  S TXT(2)="This exceeds CMOP limits."
- S TXT(3)="Lines beyond seven are not being sent to the CMOP."
+ S TXT(3)="Lines beyound seven are not being sent to the CMOP."
  S TXT(4)=" ",TXT(5)="Pharmacy Site: "_$$GET1^DIQ(59,PSOSITE,.01),L=5
  F NODE=6,7,4 I $DATA(WARN(NODE)) S L=L+1,TXT(L)=XT(NODE)_"     "_WARN(NODE)_" lines"
Index: FOIAVistA/tag/r/CMOP-PSX/PSXMISC1.m
===================================================================
--- FOIAVistA/trunk/r/CMOP-PSX/PSXMISC1.m	(revision 631)
+++ FOIAVistA/tag/r/CMOP-PSX/PSXMISC1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSXMISC1 ;BIR/WPB,BAB-Transmission Data Validation ;MAR 1,2002@13:13:34
- ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58,64**;11 Apr 97;Build 1
+ ;;2.0;CMOP;**3,18,23,28,30,42,41,52,54,58**;11 Apr 97;Build 2
  ;Reference to ^PSDRUG(  supported by DBIA #1983
  ;Reference to ^PS(52.5, supported by DBIA #1978
@@ -124,6 +124,5 @@
  N DFN,PSOFORGN
  S DFN=$P($G(^PSRX(TRX,0)),"^",2) I DFN="" Q:0
- ;BHW;PSX*2*64;Changed Quit below from Q:+(^TMP... to Q +(^TMP...
- I $D(^TMP($J,"PSXBAI",DFN)) Q +(^TMP($J,"PSXBAI",DFN))
+ I $D(^TMP($J,"PSXBAI",DFN)) Q:+(^TMP($J,"PSXBAI",DFN))
  D ADD^VADPT
  S PSOFORGN=$P($G(VAPA(25)),"^",2) I PSOFORGN'="",PSOFORGN'["UNITED STATES" S PSOFORGN=1
Index: FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m
===================================================================
--- FOIAVistA/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m	(revision 631)
+++ FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL7.m	(revision 636)
@@ -1,52 +1,29 @@
-GMRCSTL7 ;SLC/JFR/WAT - DRIVER FOR CSLT PER MONITOR ;4/8/05 10:28
- ;;3.0;CONSULT/REQUEST TRACKING;**41,60**;DEC 27, 1997;Build 9
+GMRCSTL7 ;SLC/JFR - DRIVER FOR CSLT PER MONITOR ;4/8/05 10:28
+ ;;3.0;CONSULT/REQUEST TRACKING;**41**;DEC 27, 1997
  ;
- ;This routine invokes ICRs 
- ;1519(XUTMDEVQ,10103(XLFDT),10104(XLFSTR),3744(VADPT),10089(%ZISC),10026(DIR)
  Q
  ;
 EN ; start here
  K GMRCQUT
- N DIROUT,DTOUT,DUOUT,DIR,Y,X,GMRCTMP,GMRCDG,GMRCSVC,GMRCSVNM,GMRCDT1
+ N DIROUT,DTOUT,DUOUT,DIR,DIRUT,GMRCTMP,GMRCDG,GMRCSVC,GMRCSVNM,GMRCDT1
  N GMRCDT2,GMRCFMT,GMRCGRP,VALMBCK,GMRCSAVE
- N GMRC30ST,GMRC30SP
- D CAVEATS
+ ;
  ;Ask for service
- S DIR(0)="P^123.5:EMQ",DIR("??")="^D LISTALL^GMRCASV"
+ N Y
+ S DIR(0)="PO^123.5:EMQ",DIR("??")="^D LISTALL^GMRCASV"
  S DIR("A")="Select Service/Specialty"
  D ^DIR
- I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q
+ I Y<1 Q
  S GMRCDG=+Y,GMRCSVNM=$P(Y,U,2)
-  ;Ask for current FY
- N DIROUT,DTOUT,DUOUT,DIR,Y,X,GMRCFY
- S DIR(0)="F^4:4^K:(X-1700)>($E(DT,1,3)+1) X"
- S DIR("A")="Current Fiscal Year (i.e. 2008)"
- S DIR("A",1)="Ensure you are providing fiscal year, NOT calendar year."
- D ^DIR
- I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q
- S GMRCFY=X
- N DIROUT,DTOUT,DUOUT,DIR,Y,X,GMRCQTR,GMRCYR
- S DIR(0)="N^1:4"
- S DIR("A")="Enter a number 1 - 4"
- S DIR("A",1)="For which quarter are you running the report: first, second, third or fourth?"
- D ^DIR
- I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q
- S GMRCQTR=X
- ;if first quarter
- I $G(GMRCQTR)=1 D
- .;use FY-1 to set year part of date range to the previous calendar year
- .S GMRCYR=$G(GMRCFY)-1700 S GMRCYR=$G(GMRCYR)-1,GMRCDT1=$E($G(GMRCYR),1,3)_"1001" S GMRCDT2=$G(GMRCYR)_"1231"
- I $G(GMRCQTR)=2 D
- .S GMRCYR=$G(GMRCFY)-1700 S GMRCDT1=$E($G(GMRCYR),1,3)_"0101" S GMRCDT2=$G(GMRCYR)_"0331"
- I $G(GMRCQTR)=3 D
- .S GMRCYR=$G(GMRCFY)-1700 S GMRCDT1=$E($G(GMRCYR),1,3)_"0401" S GMRCDT2=$G(GMRCYR)_"0630"
- I $G(GMRCQTR)=4 D
- .S GMRCYR=$G(GMRCFY)-1700 S GMRCDT1=$E($G(GMRCYR),1,3)_"0701" S GMRCDT2=$G(GMRCYR)_"0930"
- S GMRC30ST=$$FMADD^XLFDT(GMRCDT1,-30),GMRC30SP=$$FMADD^XLFDT(GMRCDT2,-30)
+ ;
+ ;Ask for date range
+ D ^GMRCSPD
+ I $D(GMRCQUT) G EXIT
+ ;
  ; what type of report
- N DIROUT,DTOUT,DUOUT,DIR,Y,X
+ K DIR,X,Y
  S DIR(0)="S:O^S:Summary;D:Delimited",DIR("A")="What type of report"
  D ^DIR
- I $D(DTOUT)!($D(DUOUT))!($D(DIROUT))!(X="") D EXIT Q
+ I Y="" G EXIT
  S GMRCFMT=$S(Y="S":"CP",1:"DEL")
  ;
@@ -56,15 +33,6 @@
  S GMRCSAVE("GMRCDT1")=""
  S GMRCSAVE("GMRCDT2")=""
- S GMRCSAVE("GMRC30ST")=""
- S GMRCSAVE("GMRC30SP")=""
  S GMRCSAVE("GMRCSVNM")=""
- S GMRCSAVE("GMRCFY")=""
- S GMRCSAVE("GMRCQTR")=""
  ;
- N DIROUT,DTOUT,DUOUT,DIR,Y,X S DIR(0)="FO",DIR("A")="ENTER ""?"" FOR MORE HELP OR RETURN TO CONTINUE"
- S DIR("A",1)="MARGIN WIDTH IS BEST AT 256"
- S DIR("?")="^D MARGHLP^GMRCSTL7"
- D:GMRCFMT="DEL" ^DIR
- I $D(DTOUT)!($D(DUOUT))!($D(DIROUT)) D EXIT Q
  D EN^XUTMDEVQ("PRNTQ^GMRCSTL7","CONSULT PERFORMANCE MONITOR",.GMRCSAVE)
  ;
@@ -72,24 +40,10 @@
  ;
  Q
-MARGHLP ;help text to set margins
- W !,"Specify a device with optional parameters in the format"
- W !,?8,"Device Name;Right Margin;Page Length"
- W !,?21,"or"
- W !,?5,"Device Name;Subtype;Right Margin;Page Length"
- W !!,"Or in the new format"
- W !,?14,"Device Name;/settings"
- W !,?21,"or"
- W !,?10,"Device Name;Subtype;/settings"
- W !,"For example"
- W !,?17,"HOME;80;999"
- W !,?21,"or"
- W !,?13,"HOME;C-VT320;/M80L999"
- Q
  ;
-ENOR(RETURN,GMRCSVC,GMRC30ST,GMRC30SP,GMRCSTAT,GMRCST2,GMRCARRN) ;Entry point 
+ENOR(RETURN,GMRCSVC,GMRCDT1,GMRCDT2,GMRCSTAT,GMRCARRN) ;Entry point 
  ;.RETURN:   This is the root to the returned temp array.
  ;GMRCSVC:  Service for which consults are to be displayed.
- ;GMRC30ST:  30 days prior to quarter start date
- ;GMRC30SP:  30 days prior to quarter end date
+ ;GMRCDT1:  Starting date or "ALL"
+ ;GMRCDT2:  Ending date if not GMRCDT1="ALL"
  ;GMRCSTAT: The list of status to include separated by commas
  ;GMRCARRN: Format of report becomes ^TMP array element
@@ -112,10 +66,14 @@
  D SERV1^GMRCASV
  ;Get external form of date range
+ I '($D(GMRCDT1)#2) S GMRCDT1="ALL"
+ S:GMRCDT1="ALL" GMRCDT2=0
  D LISTDATE^GMRCSTU1(GMRCDT1,$G(GMRCDT2),.GMRCEDT1,.GMRCEDT2)
  ;
- N GMRCDA,INDEX,STATUS,STATUS2,LOOP,GROUPER
- N GMRCSVCG,GMRCPT,GMRCSVCP,GRP,PIECE,TYPE
+ N GMRCDA,INDEX,STATUS,LOOP,GROUPER
+ N STS,GMRCD,GMRCDT,GMRCSVCG,TEMP,GMRCPT,LINETEMP
+ N GMRCPTN,GMRCPTSN,GMRCDLA,GMRCXDT,GMRCLOC,GMRCSVCP
+ N GRP,GMRCIRF,GMRCIRFN,GMRCIDD,GMRCST,GMRCRDT
  ;
- K ^TMP("GMRCR",$J,GMRCARRN),^TMP("GMRCRINDEX",$J),^TMP("GMRCT",$J)
+ K ^TMP("GMRCR",$J,GMRCARRN),^TMP("GMRCRINDEX",$J),^TMP("GMRCTOT",$J)
  ;
  S GROUPER=0
@@ -123,6 +81,6 @@
  I GMRCARRN="DEL" D
  . N STR
- . S STR="Svc;30DayRng;60DayRng;CmpIn30;Cmp31-60;B4Qtr;PndB4Qtr;%Cmp30;%Cmp60;%UnRsB4Qtr;IS30Rng;IS60Rng;ISCmp30;ISCmp31-60;ISB4Qtr;ISPndB4Qtr;%ISCmp30;%ISCmp60;%ISUnRsB4Qtr;"
- . S STR=STR_"IR30Rng;IR60Rng;IRCmp30;IRCmp31-60;IRB4Qtr;IRPndB4Qtr;%IRCmp30;%IRCmp60;%IRUnRsB4Qtr"
+ . S STR="Service;Total;Unresolved;Complete;Comp w/Results;%Complete;"
+ . S STR=STR_"%Comp w/Results"
  . S ^TMP("GMRCR",$J,GMRCARRN,1,0)=STR
  S INDEX=""
@@ -132,17 +90,20 @@
  .S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,INDEX),"^",2)
  .S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,INDEX),"^",3)
- .N SUBIDX
- .;pieces for tmp arrays, 1 to 6 are local, 7 to 12 are IFC placer, 13 to 18 are IFC filler
- .;;total for 30 day start/end^total for 60 day start/end^results n 30 days^results n 60 days^total before quarter^total pending before quarter
- .S ^TMP("GMRCT",$J,1,GMRCSVC,"DATA")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
- .S ^TMP("GMRCT",$J,2,GMRCSVC,"DATA")="0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
- .;Check if starting a new Grouper
- .F  Q:GROUPER(GROUPER)=GMRCSVCG  D
+ .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"T")=0
+ .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"P")=0
+ .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"R")=0
+ .S ^TMP("GMRCTOT",$J,1,GMRCSVC,"C")=0
+ .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"T")=0
+ .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"P")=0
+ .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"R")=0
+ .S ^TMP("GMRCTOT",$J,2,GMRCSVC,"C")=0
+ . ;Check if starting a new Grouper
+ . F  Q:GROUPER(GROUPER)=GMRCSVCG  D
  ..;End of a group so print the group totals
  ..I GROUPER(GROUPER)=GMRCSVCG D 
  ... I GMRCARRN="CP" D
- ....D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN)
- ...I GMRCARRN="DEL" D
- ....D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN)
+ .... D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN)
+ ... I GMRCARRN="DEL" D
+ .... D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),GMRCARRN)
  ..;pop grouper from stack
  ..S GROUPER=GROUPER-1
@@ -153,29 +114,31 @@
  .;Loop for one status at a time
  .F LOOP=1:1:$L(GMRCSTAT,",") S STATUS=$P(GMRCSTAT,",",LOOP) D
- ..D ONESTAT^GMRCSTL8(GMRCARRN,INDEX,STATUS,GMRC30ST,GMRC30SP,"30")
- .F LOOP=1:1:$L(GMRCSTAT,",") S STATUS=$P(GMRCSTAT,",",LOOP) D
- ..D ONESTAT^GMRCSTL8(GMRCARRN,INDEX,STATUS,$$FMADD^XLFDT(GMRC30ST,-30),$$FMADD^XLFDT(GMRC30SP,-30),"60")
- .S GMRCDT1=$$FMADD^XLFDT(GMRC30ST,30) ;add 30 days back to set date back to start of FY quarter.
- .F LOOP=1:1:$L(GMRCST2,",") S STATUS2=$P(GMRCST2,",",LOOP) D
- ..D ONESTAT2^GMRCSTL8(GMRCARRN,INDEX,STATUS2,$$FMADD^XLFDT(GMRCDT1,-60))
+ .. D ONESTAT^GMRCSTL8(GMRCARRN,INDEX,STATUS,GMRCDT1,GMRCDT2)
  .F GRP=GROUPER:-1:1 D
- ..F PIECE=1:1:18 D
- ...S $P(^TMP("GMRCT",$J,2,GROUPER(GRP),"DATA"),U,PIECE)=$P(^TMP("GMRCT",$J,2,GROUPER(GRP),"DATA"),U,PIECE)+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,PIECE)
+ ..;  pending for this service to all of its groupers
+ ..S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"P")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"P"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"P")
+ .. ; completed w/results for all groupers
+ .. S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"R")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"R"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"R")
+ ..;  for all status for this service to all of its groupers
+ ..S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"T")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"T"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"T")
+ .. ; add all completed for all groupers
+ .. S ^TMP("GMRCTOT",$J,2,GROUPER(GRP),"C")=$G(^TMP("GMRCTOT",$J,2,GROUPER(GRP),"C"))+^TMP("GMRCTOT",$J,1,GMRCSVC,"C")
  .;
  .;Print the totals for this service that are >0
- .I GMRCARRN="CP" D
- ..D PRTTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN)
- .I GMRCARRN="DEL" D
- ..D DELTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN)
- .Q
+ . I GMRCARRN="CP" D 
+ .. D PRTTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN)
+ . I GMRCARRN="DEL" D
+ .. D DELTOT^GMRCSTL8(1,GMRCSVC,GMRCSVCP,GMRCARRN)
+ . Q
  ;
  ;Done, so now list the group totals for the top group
  ;F GROUPER=GROUPER:-1:1 D  ; left for looking at all totals in future
  I $G(GROUPER) S GROUPER=1 D
- .I GMRCARRN="CP" D
- ..D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN)
- .I GMRCARRN="DEL" D
- ..D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN)
+ . I GMRCARRN="CP" D 
+ .. D PRTTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN)
+ . I GMRCARRN="DEL" D
+ .. D DELTOT^GMRCSTL8(2,GROUPER(GROUPER),$P(^GMR(123.5,GROUPER(GROUPER),0),"^",1),GMRCARRN)
  Q
+ ;
 PRNTQ   ;Build report and print it
  ;
@@ -184,45 +147,38 @@
  D SERV1^GMRCASV
  D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
- S TEMP=$S($G(GMRCQTR)=4:"4",$G(GMRCQTR)=3:"3",$G(GMRCQTR)=2:"2",1:"1")_"Q"_"FY"_$E($G(GMRCFY),3,4)
- S TEMP="Consult/Request Performance Monitor - "_TEMP
- W $J("",40-($L(TEMP)/2)+.5)_TEMP
- S TEMP="Fiscal Quarter Dates: "_$$FMTE^XLFDT(GMRCDT1)_" - "_$$FMTE^XLFDT(GMRCDT2)
- W !,$J("",40-($L(TEMP)/2)+.5)_TEMP
- S TEMP="30 Days Before Start/End: "_$$FMTE^XLFDT(GMRC30ST)_" - "_$$FMTE^XLFDT(GMRC30SP)
- W !,$J("",40-($L(TEMP)/2)+.5)_TEMP
- S TEMP="60 Days Before Start/End: "_$$FMTE^XLFDT($$FMADD^XLFDT(GMRC30ST,-30))_" - "_$$FMTE^XLFDT($$FMADD^XLFDT(GMRC30SP,-30))
+ W !,$J("",23)_"Consult/Request Performance Monitor"
+ S TEMP="FROM: "_$$FMTE^XLFDT(GMRCDT1)_"  TO: "_$$FMTE^XLFDT(GMRCDT2)
+ I GMRCDT1="ALL" S TEMP="ALL DATES"
  W !,$J("",40-($L(TEMP)/2)+.5)_TEMP,!
- I '$D(IO("Q")) D WAIT^DICD W !!
  I '$O(^TMP("GMRCSLIST",$J,0)) D  G EXIT
- .W !!,"No records to print"
- D ENOR^GMRCSTL7(.GMRCTMP,GMRCDG,GMRC30ST,GMRC30SP,"2,5,6,8,9","1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,99",GMRCFMT)
+ . W !!,"No records to print"
+ D ENOR^GMRCSTL7(.GMRCTMP,GMRCDG,GMRCDT1,GMRCDT2,"5,6,8,2,9",GMRCFMT)
  I '$D(^TMP("GMRCR",$J,GMRCFMT)) D
- .W !!,"No records to print",!
+ . W !!,"No records to print",!
  S IDX=""
  F  S IDX=$O(^TMP("GMRCR",$J,GMRCFMT,IDX)) Q:'IDX!($G(GMRCQUT))  D
- .I IOSL-$Y<3 D
- ..I $E(IOST,1,2)["C-" D
- ...N DIR S DIR(0)="E" D ^DIR
- ...I 'Y S GMRCQUT=1
- ..Q:$G(GMRCQUT)
- ..D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
- .Q:$G(GMRCQUT)
- .W ^TMP("GMRCR",$J,GMRCFMT,IDX,0),!
- D:$D(^TMP("GMRCR",$J,GMRCFMT)) CAVEATS
+ . I IOSL-$Y<3 D
+ .. I $E(IOST,1,2)["C-" D
+ ... N DIR S DIR(0)="E" D ^DIR
+ ... I 'Y S GMRCQUT=1
+ .. Q:$G(GMRCQUT)
+ .. D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
+ . Q:$G(GMRCQUT)
+ . W ^TMP("GMRCR",$J,GMRCFMT,IDX,0),!
  I GMRCFMT="CP",'$G(GMRCQUT) D
- .Q:$O(^TMP("GMRCT",$J,0,""))=""
- .I IOSL-$Y<6 D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
- .W !!!,$$REPEAT^XLFSTR("-",IOM-5)
- .W !,"Consult services not meeting the criteria of this report for",!,"the specified date range:",!
- .S IDX=""
- .F  S IDX=$O(^TMP("GMRCT",$J,0,IDX)) Q:IDX=""!($G(GMRCQUT))  D
- ..I IOSL-$Y<3 D
- ...I $E(IOST,1,2)["C-" D
- ....N DIR S DIR(0)="E" D ^DIR
- ....I 'Y S GMRCQUT=1
- ...Q:$G(GMRCQUT)
- ...D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
- ..Q:$G(GMRCQUT)
- ..W ?4,IDX,!
+ . Q:$O(^TMP("GMRCTOT",$J,0,""))=""
+ . I IOSL-$Y<6 D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
+ . W !!!,$$REPEAT^XLFSTR("-",IOM-5)
+ . W !,"Consult services with no activity meeting the criteria of this report in",!,"the specified date range:",!
+ . S IDX=""
+ . F  S IDX=$O(^TMP("GMRCTOT",$J,0,IDX)) Q:IDX=""!($G(GMRCQUT))  D
+ .. I IOSL-$Y<3 D
+ ... I $E(IOST,1,2)["C-" D
+ .... N DIR S DIR(0)="E" D ^DIR
+ .... I 'Y S GMRCQUT=1
+ ... Q:$G(GMRCQUT)
+ ... D HEAD(GMRCPG) S GMRCPG=GMRCPG+1
+ .. Q:$G(GMRCQUT)
+ .. W ?4,IDX,!
  D ^%ZISC
  D EXIT
@@ -231,26 +187,10 @@
 HEAD(PAGE) ; print header for CPM
  W @IOF
- I PAGE>1 D
- .S TEMP=$S($G(GMRCQTR)=4:"4",$G(GMRCQTR)=3:"3",$G(GMRCQTR)=2:"2",1:"1")_"Q"_"FY"_$E($G(GMRCFY),3,4)
- .S TEMP="Consult/Request Performance Monitor - "_TEMP
- .W !,$J("",40-($L(TEMP)/2)+.5)_TEMP,!
- W !,$J("Run Date: "_$$HTE^XLFDT($H),0),$J("Page: "_PAGE,48)
- W !,$$REPEAT^XLFSTR("-",IOM-2),!!
+ W "Consult Performance Monitor",?40,$$HTE^XLFDT($H)
+ W ?73,"Page: ",PAGE,!
+ W $$REPEAT^XLFSTR("-",IOM-2),!
  Q
  ;
-CAVEATS ; brief explanatory text
- W !!,"Resubmitted requests are evaluated based on the original Date of Request."
- W !!,"The following are excluded from this report:"
- W !," -Requests sent to test patients."
- W !," -Requests not marked as Outpatient in the REQUEST/CONSULTATION file."
- W !," -Services flagged as part of the interface between Consults/Request Tracking"
- W !,?2,"and Prosthetics."
- W !," -Administrative requests flagged via the Administrative fields in the"
- W !,?2,"REQUEST SERVICES and REQUEST/CONSULTATION files. This is not retroactive"
- W !,?2,"and only applies to services/requests leveraging the Administrative-flagging"
- W !,?2,"capability included in GMRC*3.0*60, available on or about June 2008.",!!
- Q
- ;
-EXIT F ARR="GMRCR","GMRCS","GMRCSLIST","GMRCT" K ^TMP(ARR,$J)
+EXIT F ARR="GMRCR","GMRCS","GMRCSLIST","GMRCTOT" K ^TMP(ARR,$J)
  K ARR
  Q
Index: FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m
===================================================================
--- FOIAVistA/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m	(revision 631)
+++ FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCSTL8.m	(revision 636)
@@ -1,194 +1,113 @@
-GMRCSTL8 ;SLC/JFR/WAT - Totals format for CPM ; 4/05/05 10:39
- ;;3.0;CONSULT/REQUEST TRACKING;**41,60**;DEC 27, 1997;Build 9
- ; This routine invokes ICRs
- ; 875 (file 100.01), 2638 (file 100.01),10104 (XLFSTR),10103 (XLFDT),3744 (VADPT)
+GMRCSTL8 ;SLC/JFR - Totals format for CPM ; 4/05/05 10:39
+ ;;3.0;CONSULT/REQUEST TRACKING;**41**;DEC 27, 1997
+ ; This routine invokes IA #875, #2638
+ ; This routine invokes IA #10035,#44, #10040
  ;
  ; portions copied from GMRCSTL1 & GMRCSTL2
+ ;
  Q  ; can't start here
+ ;
 PRTTOT(GEN,INDEX,NAME,ARRN) ; totals for printed report
- N QUIT S QUIT=0 D NOACTVT Q:QUIT=1
- N GMRCPCT,LAYOUT,FRMT,ROWTEXT,CALC1,CALC2,CALC3,ROWTXT
- N COUNT,SVCUSG
+ N COUNT
  S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1)
  I GEN=2 D
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=""
- .S SVCUSG=$P(^GMR(123.5,INDEX,0),U,2) I $G(SVCUSG) S NAME=NAME_$S(SVCUSG=1:" <grouper only>",SVCUSG=2:"   <disabled>",1:"")
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="     GROUPER: "_NAME_" Totals:"
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("WITHIN     IFC     IFC",75)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("FACILITY   SENT    REC'D",77)
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)=""
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="     GROUPER: "_NAME_" Totals:"
  I GEN=1 D
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=" "
- .I $P(^GMR(123.5,INDEX,0),U,2)=9 S NAME=NAME_"   <disabled>"
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="SERVICE: "_NAME
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("WITHIN     IFC      IFC",76)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=$J("FACILITY   SENT     REC'D",78)
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 30 Days Before Start/End of Qtr:"_ROWTXT
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 60 Days Before Start/End of Qtr:"_ROWTXT
- I GEN=2 D
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 30 Days Before Start/End of Qtr:"_ROWTXT
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2),8)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests in 60 Days Before Start/End of Qtr:"_ROWTXT
- I GEN=1!(GEN=2) D
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,3),12)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,9),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,15),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="Complete with Results in 30 Days of Request:"_ROWTXT
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,4),12)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,10),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,16),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="Complete with Results 31-60 Days of Request:"_ROWTXT
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests Created 60 Days Before Qtr Start:"_ROWTXT
- .S ROWTXT=$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,6),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,12),10)_$J($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,18),9)
- .S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)="All Requests Pending 60 Days Before Qtr Start:"_ROWTXT
- .;% complete in 30 days of request
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,3)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U))*100,2,2)_"%"
- .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1)
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,9)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,7))*100,2,2)_"%"
- .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2)
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,15)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,13))*100,2,2)_"%"
- .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3)
- .S COUNT=COUNT+1
- .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Complete w/Results in 30 Days of Request: "_ROWTXT
- .;% complete in 60 days of request
- .K CALC1,CALC2,CALC3
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,4)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,2))*100,2,2)_"%"
- .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1)
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,10)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,8))*100,2,2)_"%"
- .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2)
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,16)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,14))*100,2,2)_"%"
- .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3)
- .S COUNT=COUNT+1
- .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Complete w/Results 31-60 Days of Request: "_ROWTXT
- .;% pending before quarter start
- .K CALC1,CALC2,CALC3
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5)>0 S CALC1=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,6)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,5))*100,2,2)_"%"
- .S ROWTXT=$S($G(CALC1)="":$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC1))_CALC1)
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11)>0 S CALC2=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,12)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,11))*100,2,2)_"%"
- .S ROWTXT=ROWTXT_$S('$D(CALC2):$$REPEAT^XLFSTR(" ",10-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",10-$L(CALC2))_CALC2)
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17)>0 S CALC3=$J(($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,18)/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,17))*100,2,2)_"%"
- .S ROWTXT=ROWTXT_$S($G(CALC3)="":$$REPEAT^XLFSTR(" ",9-$L("N / A"))_"N / A",1:$$REPEAT^XLFSTR(" ",9-$L(CALC3))_CALC3)
- .S COUNT=COUNT+1
- .S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percent Still Pending Created Before Qtr Start:   "_ROWTXT
+ . I ^TMP("GMRCTOT",$J,1,INDEX,"T")=0 D  Q  ;collect zero servs for summ
+ .. Q:$P(^GMR(123.5,INDEX,0),U,2)=1
+ .. S ^TMP("GMRCTOT",$J,0,NAME)=""
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)=" "
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="SERVICE: "_NAME
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests To Service:"_$J(^TMP("GMRCTOT",$J,1,INDEX,"T"),30,0)
+ I GEN=2,^TMP("GMRCTOT",$J,2,INDEX,"T")>0 D
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests To Grouper:"_$J(^TMP("GMRCTOT",$J,2,INDEX,"T"),30,0)
+ I $G(^TMP("GMRCTOT",$J,GEN,INDEX,"T"))>0 D
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests Pending Resolution: "_$J(^TMP("GMRCTOT",$J,GEN,INDEX,"P"),21,0)
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests completed: "_$J(^TMP("GMRCTOT",$J,GEN,INDEX,"C"),30,0)
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Total Requests completed with Results: "_$J(^TMP("GMRCTOT",$J,GEN,INDEX,"R"),17,0)
+ . N GMRCPCT
+ . I ^TMP("GMRCTOT",$J,GEN,INDEX,"T")=0 S GMRCPCT="N/A"
+ . I '$D(GMRCPCT) S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"C")/^TMP("GMRCTOT",$J,GEN,INDEX,"T"))*100
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percentage of total requests completed: "_$S(+GMRCPCT'=GMRCPCT:$J(GMRCPCT,16),1:($J(GMRCPCT,19,2)_"%"))
+ . K GMRCPCT
+ . I ^TMP("GMRCTOT",$J,GEN,INDEX,"C")=0 S GMRCPCT="N/A"
+ . I '$D(GMRCPCT) S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"R")/^TMP("GMRCTOT",$J,GEN,INDEX,"C"))*100
+ . S COUNT=COUNT+1
+ . S ^TMP("GMRCR",$J,ARRN,COUNT,0)="Percentage of total completed requests with results: "_$S(+GMRCPCT'=GMRCPCT:GMRCPCT,1:($J(GMRCPCT,6,2)_"%"))
  Q
+ ;
 DELTOT(GEN,INDEX,NAME,ARRN) ; format for delimited
- N QUIT S QUIT=0 D NOACTVT Q:QUIT=1
- N STRING,COUNT,PIECE,INCR,SVCUSG
- S SVCUSG=$P(^GMR(123.5,INDEX,0),U,2) I $G(SVCUSG) S NAME=NAME_$S(SVCUSG=1:" <grouper only>",SVCUSG=2:" <disabled>",1:"")
- S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1),STRING=$S(GEN=2:"GROUPER: ",1:"")_NAME_";"
- F PIECE=1:1:18 D
- .S STRING=STRING_$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,PIECE)_";"
- .I PIECE=6!(PIECE=12)!(PIECE=18) D
- ..S INCR=$S(PIECE=6:0,PIECE=12:6,1:12)
- ..;percents
- ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(1+INCR))=0 S STRING=STRING_"N/A;"
- ..E  S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(3+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(1+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";"
- ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(2+INCR))=0 S STRING=STRING_"N/A;"
- ..E  S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(4+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(2+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";"
- ..I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(5+INCR))=0 S STRING=STRING_"N/A;"
- ..E  S GMRCPCT=($P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(6+INCR))/$P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,(5+INCR)))*100,STRING=STRING_$J(GMRCPCT,0,2)_";"
- S COUNT=COUNT+1,^TMP("GMRCR",$J,ARRN,COUNT,0)=STRING
+ ;
+ I ^TMP("GMRCTOT",$J,GEN,INDEX,"T")=0 Q
+ N STRING,COUNT
+ S COUNT=$O(^TMP("GMRCR",$J,ARRN," "),-1)
+ S STRING=$S(GEN=2:"GROUPER: ",1:"")_NAME_";"
+ S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"T")_";"
+ S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"P")_";"
+ S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"C")_";"
+ S STRING=STRING_^TMP("GMRCTOT",$J,GEN,INDEX,"R")_";"
+ D  ;get % completed
+ . N GMRCPCT
+ . S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"C")/^TMP("GMRCTOT",$J,GEN,INDEX,"T"))*100
+ . S STRING=STRING_$J(GMRCPCT,0,2)_";"
+ . Q
+ D  ; get % completed w/results
+ . I ^TMP("GMRCTOT",$J,GEN,INDEX,"C")=0 S STRING=STRING_"N/A;" Q
+ . N GMRCPCT
+ . S GMRCPCT=(^TMP("GMRCTOT",$J,GEN,INDEX,"R")/^TMP("GMRCTOT",$J,GEN,INDEX,"C"))*100
+ . S STRING=STRING_$J(GMRCPCT,0,2)
+ . Q
+ S COUNT=COUNT+1
+ S ^TMP("GMRCR",$J,ARRN,COUNT,0)=STRING
  Q
-NOACTVT ;services with no activity for the reporting period
- N CONT,PIECE S CONT=1
- I GEN=1&($P(^GMR(123.5,INDEX,0),U,2)=1) S QUIT=1 Q  ;;don't add to list if service is a grouper only...
- F PIECE=1:1:18 D  Q:CONT=0
- .I $P(^TMP("GMRCT",$J,GEN,INDEX,"DATA"),U,PIECE)>0 S CONT=0 Q
- S:CONT=1 ^TMP("GMRCT",$J,0,NAME)="",QUIT=1
- Q
-ONESTAT(ARRN,SVCN,STAT,DT1,DT2,STR) ;Process one status
- ;Input -- ARRN  "CP"  - to be printed  or "DEL" - in delimited format
- ;SVCN = node in ^TMP("GMRCLIST,$J..STAT = status being worked on..DT1 = starting date..DT2 = ending date
- ;STR = string value used to store 30/60 day results in correct piece of ^tmp arrays
- ;Output - None
- N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP,GMRCQT,FLG,TYPE
+ ;
+ONESTAT(ARRN,SVCN,STAT,DT1,DT2) ;Process one status
+ ; Input -- ARRN  "CP"  - to be printed 
+ ;                "DEL" - in delimited format
+ ;          SVCN = node in ^TMP("GMRCLIST,$J
+ ;          STAT = status being worked on
+ ;          DT1 = starting date
+ ;          DT2 = ending date
+ ;
+ ; Output - None
+ ;
+ N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP
  S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1)
  S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2)
  S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3)
- S GMRCXDT=9999999-DT2-.6  ;start searching the global at a date a fraction newer than DT2 (the end date for this search)
+ S GMRCXDT=$S(DT1="ALL":0,1:9999999-DT2-.6)
  F  S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT=""!(GMRCXDT>(9999999-DT1))  D
  .S GMRCPT=0
  .;Loop for one consult at a time
- .F  S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT=""  D 
- ..S FLG=0 D EXCLUDE Q:$G(FLG)=1
- ..S TYPE="" D REQTYPE
- ..I TYPE="LOCAL" D  ;set totals for 30 and 60 day range
- ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U)+1
- ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,2)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,2)+1
- ...I STAT=2 D
- ....Q:'$O(^GMR(123,+$G(GMRCPT),50,0))  ;Q if no results
- ....D CHKRNG
- ..I TYPE="IFCP" D
- ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,7)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,7)+1
- ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,8)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,8)+1
- ...D:STAT=2 CHKRNG
- ..I TYPE="IFCF" D
- ...S:STR="30" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,13)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,13)+1
- ...S:STR="60" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,14)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,14)+1
- ...D:STAT=2 CHKRNG
+ .F  S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT=""  D
+ .. N PROS
+ ..; Check for bad "AE" x-ref
+ ..I '$D(^GMR(123,GMRCPT,0)) D  Q
+ ...K ^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)
+ .. I $$TESTPAT^VADPT(+$P(^GMR(123,GMRCPT,0),U,2)) Q  ; exclude test pats
+ .. D  I $G(PROS) Q
+ ... N SVC S SVC=$P(^GMR(123,GMRCPT,0),U,5)
+ ... I +$G(^GMR(123.5,SVC,"INT")) S PROS=1 ; exclude PROS consults
+ .. I $P($G(^GMR(123,GMRCPT,12)),U,5)="P" Q  ; exclude IFC placer
+ ..; Add to totals
+ ..; for all status for this service
+ ..S ^TMP("GMRCTOT",$J,1,GMRCSVC,"T")=^TMP("GMRCTOT",$J,1,GMRCSVC,"T")+1
+ ..;  pending for this service
+ ..S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") ^TMP("GMRCTOT",$J,1,GMRCSVC,"P")=^TMP("GMRCTOT",$J,1,GMRCSVC,"P")+1
+ .. I STAT=2 D
+ ... S ^TMP("GMRCTOT",$J,1,GMRCSVC,"C")=+$G(^TMP("GMRCTOT",$J,1,GMRCSVC,"C"))+1
+ ... Q:'$O(^GMR(123,+$G(GMRCPT),50,0))  ; Q if no results
+ ... S ^TMP("GMRCTOT",$J,1,GMRCSVC,"R")=+$G(^TMP("GMRCTOT",$J,1,GMRCSVC,"R"))+1
  Q
  ;
-ONESTAT2(ARRN,SVCN,STAT,DT1) ;all statuses, all requests, before quarter start
- ;Input -- ARRN  "CP"  - to be printed or "DEL" - in delimited format
- ;SVCN = node in ^TMP("GMRCLIST,$J..STAT = status being worked on..DT1 = 60 days before starting date of current quarter
- ;Output -- None
- N GMRCPT,GMRCXDT,TEMP,GMRCSVC,GMRCSVCG,GMRCSVCP,FLG,TYPE
- S GMRCSVC=$P(^TMP("GMRCSLIST",$J,SVCN),"^",1)
- S GMRCSVCP=$P(^TMP("GMRCSLIST",$J,SVCN),"^",2)
- S GMRCSVCG=$P(^TMP("GMRCSLIST",$J,SVCN),"^",3)
- S GMRCXDT=""
- F  S GMRCXDT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT)) Q:GMRCXDT=""  D
- .S GMRCPT=0
- .;Loop for one consult at a time
- .F  S GMRCPT=$O(^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)) Q:GMRCPT=""  D
- ..Q:GMRCXDT<(9999999-DT1-.6)  ;
- ..S FLG=0 D EXCLUDE Q:$G(FLG)=1
- ..S TYPE="" D REQTYPE
- ..I TYPE="LOCAL" D
- ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,5)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,5)+1
- ...; get unresolved requests for the period
- ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,6)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,6)+1
- ..I TYPE="IFCP" D
- ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,11)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,11)+1
- ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,12)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,12)+1
- ..I TYPE="IFCF" D
- ...S $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,17)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,17)+1
- ...S:",3,4,5,6,8,9,11,99,"[(","_STAT_",") $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,18)=$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,18)+1
- Q
-REQTYPE  ;If the request is being requested and performed locally, this field will be blank; Placer done elsewhere, Filler done locally
- I $P(^GMR(123,$G(GMRCPT),0),U,23)="" S TYPE="LOCAL" Q
- I $P(^GMR(123,$G(GMRCPT),0),U,23)'=""&($P($G(^GMR(123,GMRCPT,12)),U,5)="P") S TYPE="IFCP" Q
- I $P(^GMR(123,$G(GMRCPT),0),U,23)'=""&($P($G(^GMR(123,GMRCPT,12)),U,5)="F") S TYPE="IFCF" Q
- Q
-EXCLUDE ;exclude these request types from the count
- N PROS
- ; Check for bad "AE" x-ref
- I '$D(^GMR(123,GMRCPT,0)) D  S FLG=1 Q
- .K ^GMR(123,"AE",GMRCSVC,STAT,GMRCXDT,GMRCPT)
- I $$TESTPAT^VADPT(+$P(^GMR(123,GMRCPT,0),U,2)) S FLG=1 Q  ; exclude test pats
- D  I $G(PROS) S FLG=1 Q
- .N SVC S SVC=$P(^GMR(123,GMRCPT,0),U,5)
- .I +$G(^GMR(123.5,SVC,"INT")) S PROS=1 ; exclude PROS consults
- I $P($G(^GMR(123,GMRCPT,0)),U,18)'="O" S FLG=1 Q  ; only getting outpat
- I $G(^GMR(123,GMRCPT,70))["Y" S FLG=1 Q  ; exclude admin requests
- Q
-CHKRNG ;check if request is complete within 30/60 days of Desired Date or Date of Request
- N DTOR,DTCMPL S DTOR="",DTCMPL=""
- Q:'$O(^GMR(123,+$G(GMRCPT),50,0))&('$O(^GMR(123,+$G(GMRCPT),51,0)))
- I $D(^GMR(123,+$G(GMRCPT),60))=1 S DTOR=$P(^GMR(123,+$G(GMRCPT),60),U,1) ;check for desired date CPRS GUI v28
- S:$G(DTOR)="" DTOR=$P(^GMR(123,+$G(GMRCPT),0),U,7)
- ; if request is completed and has results, was it completed within 30 or 60 days of the Date of Request, field 3 in 123 [0;7]
- ;order through activity multiple (40) and find the entry for completed 40, [0:2] - value of 10 is complete/update
- N CHK S CHK=0
- F  S CHK=$O(^GMR(123,+$G(GMRCPT),40,CHK)) Q:CHK="B"  D
- .;get the date/time of completion 40, [0;3]
- .I $D(^GMR(123,+$G(GMRCPT),40,CHK,0)) S:($P(^GMR(123,GMRCPT,40,CHK,0),U,2)=10) DTCMPL=$P(^GMR(123,GMRCPT,40,CHK,0),U,3)
- I $G(DTCMPL) D
- .I (STR="30")&(DTCMPL<=$$FMADD^XLFDT(DTOR,30)) D
- ..S:TYPE="LOCAL" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,3)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,3)+1
- ..S:TYPE="IFCP" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,9)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,9)+1
- ..S:TYPE="IFCF" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,15)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,15)+1
- .I STR'="30"&(DTCMPL<=$$FMADD^XLFDT(DTOR,60))&(DTCMPL>$$FMADD^XLFDT(DTOR,30)) D
- ..S:TYPE="LOCAL" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,4)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,4)+1
- ..S:TYPE="IFCP" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,10)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,10)+1
- ..S:TYPE="IFCF" $P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,16)=+$P(^TMP("GMRCT",$J,1,GMRCSVC,"DATA"),U,16)+1
- Q
Index: FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCYP57.m
===================================================================
--- FOIAVistA/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCYP57.m	(revision 631)
+++ FOIAVistA/tag/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCYP57.m	(revision 636)
@@ -1,3 +1,3 @@
-GMRCYP57 ;BP/WAT - POST INSTALL FOR GMRC*3*57 ;JUL 24, 2007 0830
+GMRCYP57 ;BP/WAT - POST INSTALL FOR GMRC*3*57 ;10:07 AM  1 Jan 2008
  ;;3.0;CONSULT/REQUEST TRACKING;**57**;DEC 27, 1997;Build 10
  ;
@@ -22,5 +22,5 @@
  S ERRMSG(3)="CONFIRM FILE ENTRY AND RE-INSTALL"
  S ERRMSG(4)="IF STILL UNSUCCESSFUL, CONTACT VA NAT'L HELP DESK OR SUBMIT REMEDY TICKET"
- S STAIEN=$$LKUP^XUAF4(528) ;return IEN from INSTITUTION file for this station number
+ S STAIEN=$$LKUP^XUAF4(528)
  I 'STAIEN D BMES^XPDUTL(ERRMSG)
  Q:'STAIEN
Index: FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m
===================================================================
--- FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m	(revision 631)
+++ FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDACT1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSDACT1 ;BIR/JPW,BJW-Print Daily Activity Log (cont'd) ; 17 Jun 98
- ;;3.0; CONTROLLED SUBSTANCES ;**10,14,30,65**;13 Feb 97;Build 5
+ ;;3.0; CONTROLLED SUBSTANCES ;**10,14,30**;13 Feb 97
  ;Reference to ^PRC(442 supported by IA #682
  ;Reference to ^PRCS(410 supported by IA #198
@@ -96,5 +96,4 @@
 T14 S NUM="GS # ",TEXT="EDIT VERIFIED ORDER"
  I +$P(NODE,"^",17) S NUM=NUM_$P(NODE,"^",17)
- S:$D(^PSD(58.81,PSDA,8)) TEXT="EDIT VERIFIED INVOICE",NUM=$P(^PSD(58.81,PSDA,8),"^",1) ; <*65-RJS>
  S QTY=$P(^PSD(58.81,PSDA,4),"^",4),BFWD=$P(^(4),"^",7)
  Q
Index: FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m
===================================================================
--- FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m	(revision 631)
+++ FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDNRGS.m	(revision 636)
@@ -1,4 +1,4 @@
 PSDNRGS ;BIR/JPW-Receive Green Sheet for NAOU ; 6 Jan 94
- ;;3.0; CONTROLLED SUBSTANCES ;**56,66,65**;13 Feb 97;Build 5
+ ;;3.0; CONTROLLED SUBSTANCES ;**56,66**;13 Feb 97;Build 3
  I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
  S OK=$S($D(^XUSEC("PSJ RNURSE",DUZ)):1,$D(^XUSEC("PSD NURSE",DUZ)):1,$D(^XUSEC("PSJ RPHARM",DUZ)):2,$D(^XUSEC("PSJ PHARM TECH",DUZ)):2,1:0)
@@ -18,20 +18,17 @@
 ORD S STAT=+$P(Y(0),"^",11),PSDPN=$P(Y(0),"^",17),STATN="" I STAT S STATN=$P($G(^PSD(58.82,STAT,0)),"^")
  S ORD=+$P(Y(0),"^",20),NAOU=+$P(Y(0),"^",18),NAOUN=$P($G(^PSD(58.8,NAOU,0)),"^"),PSDR=+$P(Y(0),"^",5),PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P(Y(0),"^",6)
- ; >> RJS - *65
- L +^PSD(58.81,PSDA):$S($G(DILOCKTM)>0:DILOCKTM,1:3)
- I '$T W !,"The Green Sheet # ",PSDPN," is currently in use by another user",!,"Please select another Green Sheet.",! G GS
  I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
- I AOU'=NAOU W $C(7),!!,"The Green Sheet # ",PSDPN," is assigned to ",NAOUN,".",!,"Please select another Green Sheet.",! L -^PSD(58.81,PSDA) G GS  ; <RJS - *65
- I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! L -^PSD(58.81,PSDA) G END  ; <RJS - *65
- I STAT'=3 W $C(7),!!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please select another Green Sheet.",! L -^PSD(58.81,PSDA) G GS  ; RJS - *65
+ I AOU'=NAOU W $C(7),!!,"The Green Sheet # ",PSDPN," is assigned to ",NAOUN,".",!,"Please select another Green Sheet.",! G GS
+ I '$D(^PSD(58.8,NAOU,1,PSDR,3,ORD,0)) W $C(7),!!,"There's no data on ",NAOUN," for Green Sheet # ",PSDPN,".",!,"Contact your Pharmacy Coordinator for assistance.",! G END
+ I STAT'=3 W $C(7),!!,"This Green Sheet has a status of "_$S(STATN]"":STATN,1:"UNKNOWN")_".",!,"Please select another Green Sheet.",! G GS
  D NOW^%DTC S (RECD,Y)=+$E(%,1,12) X ^DD("DD") S RECDT=Y
 REC ;receive at order level in 58.8
  W !!,"Accessing ",PSDRN," information...",!!
- K DA,DIR,DIRUT S DIR(0)="58.81,27",DIR("B")=QTY D ^DIR K DIR I $D(DIRUT) W !!,"Quantity not entered.  No action taken.",!,"This order remains ",STATN,!! L -^PSD(58.81,PSDA) G END  ; < RJS - *65
- S RQTY=Y I RQTY'=QTY W $C(7),!!,"The quantity received does not match the quantity dispensed.",!,"This order must be returned to pharmacy for investigation.",!! L -^PSD(58.81,PSDA) G GS  ;< RJS - *65
+ K DA,DIR,DIRUT S DIR(0)="58.81,27",DIR("B")=QTY D ^DIR K DIR I $D(DIRUT) W !!,"Quantity not entered.  No action taken.",!,"This order remains ",STATN,!! G END
+ S RQTY=Y I RQTY'=QTY W $C(7),!!,"The quantity received does not match the quantity dispensed.",!,"This order must be returned to pharmacy for investigation.",!! G GS
  K DA,DIE,DR S DA=ORD,DA(1)=PSDR,DA(2)=NAOU
  S DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",3,"
  S DR=$S(OK=1:"6////"_PSDUZ,1:"6RECEIVED BY NURSE")_";20////"_QTY_";15////"_RECD_";10////4;22////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4)_";25////"_$P($G(^PSD(58.8,NAOU,1,PSDR,0)),U,4) D ^DIE K DA,DIE,DR
- I ($D(Y))!($D(DTOUT)) W $C(7),!!,"*** THIS ORDER HAS NOT BEEN RECEIVED ***",!,"Receiving nurses name must be entered.",!!,"The status remains "_STATN,! L -^PSD(58.81,PSDA) G END  ;< RJS - *65
+ I ($D(Y))!($D(DTOUT)) W $C(7),!!,"*** THIS ORDER HAS NOT BEEN RECEIVED ***",!,"Receiving nurses name must be entered.",!!,"The status remains "_STATN,! G END
 UPDATE ;update 58.8 and 58.81
  ;updating drug balance in 58.8
@@ -51,5 +48,4 @@
  W "done.",!!
  S STAT=$P($G(^PSD(58.81,PSDA,0)),"^",11) W ?5,"*** Your Green Sheet #"_PSDPN_" is now "_$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")_" ***",!
- L -^PSD(58.81,PSDA)  ;< RJS - *65
  G GS
 END K %,%DT,%H,%I,AOU,AOUN,D,DA,DIC,DIE,DR,DTOUT,DUOUT
Index: FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m
===================================================================
--- FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m	(revision 631)
+++ FOIAVistA/tag/r/CONTROLLED_SUBSTANCES-PSD/PSDSITE.m	(revision 636)
@@ -1,6 +1,6 @@
 PSDSITE ;BIR/JPW,LTL-Site Parameters for CS ; 3 May 95
- ;;3.0; CONTROLLED SUBSTANCES ;**65**;13 Feb 97;Build 5
+ ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
 SITE ;entry for selecting inpatient sites in file 59.4
- K DIC,DLAYGO S DIC="^PS(59.4,",DLAYGO=59.4,DIC(0)="QEAL",D="B",DZ="??"
+ K DIC,DLAYGO S (DIC,DLAYGO)="^PS(59.4,",DIC(0)="QEAL",D="B",DZ="??"
  D DQ^DICQ K D,DZ W ! D ^DIC K DIC G:Y<0 END
  K DA,DIE,DR S DIE=59.4,DA=+Y,DR="31"_"Is "_$P(Y,U,2)_" selectable for Controlled Subs" W ! D ^DIE K DIE
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/DGYACPT.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/DGYACPT.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/DGYACPT.m	(revision 636)
@@ -1,4 +1,4 @@
 DGYACPT ;ALB/ABR - CPT Utilities ;3/15/97
- ;;6.0;CPT/HCPCS;;May 19, 1997
+ ;;6.0;CPT/HCPCS;;May 19, 1997;Build 1
  ;
  ;    ************************************************
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTAPIU.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTAPIU.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTAPIU.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTAPIU  ;ALB/DEK/KER - CPT UTILITIES FOR APIS ; 04/18/2004
- ;;6.0;CPT/HCPCS;**1,6,12,14,16,19,22**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**1,6,12,14,16,19,22**;May 19, 1997;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCOD.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCOD.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCOD.m	(revision 636)
@@ -1,4 +1,4 @@
-ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ;11/29/2007
- ;;6.0;CPT/HCPCS;**6,12,13,14,16,19,40**;May 19, 1997;Build 6
+ICPTCOD ;ALB/DEK/KER - CPT CODE APIS ; 04/18/2004
+ ;;6.0;CPT/HCPCS;**6,12,13,14,16,19**;May 19, 1997;Build 1
  ;
  ; External References
@@ -127,7 +127,5 @@
  .S ER="" F  S ER=$O(^DIC(81.3,"M",BR,ER)) Q:'ER  I CODA'>ER D
  ..S MI=0 F  S MI=$O(^DIC(81.3,"M",BR,ER,MI)) Q:'MI  D
- ...N MDPS
  ...S MDST=$G(^DIC(81.3,MI,0)) Q:'$L(MDST)
- ...S MDPS=$$MODP^ICPTMOD(CODE,+MI,"I",$G(CDT),$G(SRC)) Q:+MDPS'>0
  ...I '$G(SRC) Q:$P(MDST,"^",4)="V"
  ...I $G(CDT) S ACTMD="",ACTMD=$$MOD^ICPTMOD(MI,"I",CDT,$G(SRC)) Q:($P(ACTMD,"^")=-1)!($P(ACTMD,"^",7)=0)
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCR.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCR.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTCR.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTCR ;ALB/ABR - MUMPS CROSS REFERENCE ROUTINE ; 3/10/97
- ;;6.0;CPT/HCPCS;;May 19, 1997
+ ;;6.0;CPT/HCPCS;;May 19, 1997;Build 1
  ;
  ;  VARIABLES
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTID.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTID.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTID.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTID ;SLC/KER - CPT IDENTIFIERS ; 04/18/2004
- ;;6.0;CPT/HCPCS;**19**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**19**;May 19, 1997;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTIDX.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTIDX.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTIDX.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
- ;;6.0;CPT/HCPCS;**14**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**14**;May 19, 1997;Build 1
  ;
  ; ICPTCOD          CPT/HCPC Code from Global
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMIDX.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMIDX.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMIDX.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTMIDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
- ;;6.0;CPT/HCPCS;**14**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**14**;May 19, 1997;Build 1
  ;
  ; ICPTMOD          CPT/HCPC Code Modifier from Global
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD.m	(revision 636)
@@ -1,13 +1,7 @@
-ICPTMOD ;ALB/DEK/KER - CPT MODIFIER APIS ;08/18/2007
- ;;6.0;CPT/HCPCS;**6,12,13,14,19,30,37**;May 19, 1997;Build 25
- ;             
- ; Global Variables
- ;    ^DIC(81.3
- ;    ^TMP("ICPTD"     SACC 2.3.2.5.1
- ;             
+ICPTMOD ; ALB/DEK/KER - CPT MODIFIER APIS ; 09/06/2006
+ ;;6.0;CPT/HCPCS;**6,12,13,14,19,30**;May 19, 1997;Build 1
+ ;
  ; External References
- ;    $$DT^XLFDT       DBIA  10103
- ;             
- ; External References
+ ;   DBIA  10103  $$DT^XLFDT
  ;
  Q
@@ -15,5 +9,5 @@
  ;
  ; Input:   MOD   Modifier, Internal or External (Required)
- ;          MFT   Format  "I"=IEN  "E"=.01 field (Default)
+ ;          MFT   Modifier Format  "I" = IEN  "E" = .01 field (Default)
  ;          MDT   Version Date, FileMan format (default = TODAY)
  ;          SRC   Source Screen
@@ -22,5 +16,5 @@
  ;          DFN   Not used
  ; 
- ; Output:  10 piece string delimited by the up-arrow (^)
+ ; Output:  Returns a 10 piece string delimited by the up-arrow (^)
  ; 
  ;            1  IEN
@@ -55,10 +49,9 @@
  S STR=STR_"^"_EFF_"^"_$$MSG^ICPTSUPT(MDT)
  S:$L(MODST) $P(STR,"^",3)=MODST
-MODQ ; Modifier Quit
- Q STR
+MODQ Q STR
  ;
 MODD(CODE,OUTARR,DFN,CDT)       ; returns CPT description in array
  ;
- ; Input:   CODE   CPT Modifier, internal or external (Required)
+ ; Input:   CODE   CPT Modifier code, internal or external (Required)
  ;          ARY    Output Array Name
  ;                   e.g. "ABC" or "ABC("TEST")" 
@@ -66,14 +59,14 @@
  ;          DFN    Not used
  ;          CDT    Versioning Date (default = TODAY)
- ;                   If prior to 1/1/1989, 1/1/1989 will be used
- ;                   If year only, use first of that year
- ;                   If month/year only, use first of the month
- ;                   If later than today, TODAY will be used
+ ;                   If CDT is prior to 1/1/1989, 1/1/1989 will be used
+ ;                   If CDT is year only, the first of that year will be used
+ ;                   If CDT is month/year only, the first of month will be used
+ ;                   If CDT is later than today, TODAY will be used
  ; 
  ; Output:  #      Number of lines in description
  ; 
- ;          @ARY(1:n) - Versioned Description (multiple 62)
+ ;          @ARY(1:n) - Versioned Description (from the 62 multiple)
  ;          @ARY(n+1) - blank
- ;          @ARY(n+1) - message: CODE TEXT MAY BE INACCURATE
+ ;          @ARY(n+1) - a message stating: CODE TEXT MAY BE INACCURATE
  ;      or
  ;          -1^Error
@@ -98,20 +91,83 @@
  . S N=N+1,ARR=OUTARR_N_")",@ARR=$$MSG^ICPTSUPT(CDT,1)
  I +N'>0 S N="-1^VERSIONED DESCRIPTION NOT FOUND FOR MODIFIER "_$P($G(^DIC(81.3,+CODE,0)),"^",1)
-MODDQ ; Modifier Description Quit
- Q N
+MODDQ Q N
  ;
 MODA(CODE,VDT,ARY) ; Return an array of Modifiers for a CPT Code
  D MODA^ICPTMOD2 Q
+ ;
 MODP(CODE,MOD,MFT,MDT,SRC,DFN) ;  Check if modifier can be used with code
- Q $$MODP^ICPTMOD2($G(CODE),$G(MOD),$G(MFT),$G(MDT),$G(SRC),$G(DFN))
+ ;
+ ; Input:
+ ; 
+ ;    CODE   CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
+ ;    MOD    Modifier (External or Internal)
+ ;    MFT    Modifier Format "E" - or "I"
+ ;    VDT    Date service provided
+ ;    SRC    Source Screen
+ ;               If 0 or Null, Level I and II modifiers
+ ;               If >0, Level I, II, and III modifiers
+ ; Output:
+ ;
+ ;    If pair is acceptable - Positive 7 Piece "^" Delimited String
+ ;        
+ ;        1 - IEN of CPT Modifier
+ ;        2 - Versioned Short Text
+ ;        3 - Beginning Code for Code Range
+ ;        4 - Ending Code for Code Range
+ ;        5 - Code Range Activaiton Date
+ ;        6 - Code Range Inactivation Date
+ ;        7 - Modifier Identifier
+ ;        
+ ;    If pair is unacceptable
+ ;    
+ ;        0
+ ;  
+ N ACD,ADT,BEGA,BEGR,CDT,CODEA,CPTS,ENDA,ENDR,ICD,IDT,MIEN,MODEFF,MODI,MODNM,MODST,NEXT,NN,ND,PR,PRN,RIEN,SIEN,SRC,STA,STI,STX,TA,TEFF,TI,TIEN,VDT
+ S:$G(MFT)="" MFT="E" Q:"^E^I^"'[("^"_MFT_"^") "-1^Invalid Modifier Format"
+ S VDT=$P($G(MDT),".",1) Q:+VDT'>0!(VDT'?7N) "-1^Invalid Date"
+ I MFT="E" D  I +($G(MIEN))'>0 Q "-1^Multiple Modifiers with the same name, use IEN"
+ . S MIEN=0 S (TIEN,TI)=0 F  S TIEN=$O(^DIC(81.3,"B",MOD,TIEN)) Q:+TIEN'>0  D
+ . . S TEFF=$$EFF^ICPTSUPT(81.3,TIEN,VDT) Q:'$P(TEFF,"^",2)
+ . . S TI=TI+1,TA(TI)=TIEN,TA(0)=TI
+ . S:+($G(TA(0)))=1 MIEN=+($G(TA(1)))
+ S:MFT="I" MIEN=+MOD S CODE=$G(CODE)
+ S CODN=$S(CODE?1.N:+CODE,1:$$CODEN^ICPTCOD(CODE))
+ I CODN<1!'$D(^ICPT(CODN,0)) Q "-1^NO SUCH CPT CODE"
+ S CODE=$P($G(^ICPT(CODN,0)),"^") I '$L(CODE) Q:"-1^NO SUCH CPT CODE "
+ Q:$L(CODE)'=5 "-1^Invalid Code"
+ S CODEA=$S(CODE?1N.4N:+CODE,CODE?4N1A:$A($E(CODE,5))*10_$E(CODE,1,4),1:$A(CODE)_$E(CODE,2,5)) Q:+CODEA'>0 "-1^Invalid Code Source"
+ S MIEN=$G(MIEN) Q:+MIEN'>0 "-1^Invalid Modifier"
+ S SRC=+($G(SRC)) S SRC=$S(+SRC>0:1,1:0)
+ S SIEN=$O(^ICPT("BA",(CODE_" "),0)) Q:+SIEN'>0 "-3^Invalid Code"
+ S CPTS=$P($G(^ICPT(+SIEN,0)),"^",6)  Q:CPTS="L"&(SRC'>0) "-1^Invalid Code Source"
+ S MODEFF=$$EFF^ICPTSUPT(81.3,MIEN,VDT) Q:'$P(MODEFF,"^",2) "-1^Modifier Inactive"
+ S MODNM=$P($G(^DIC(81.3,MIEN,0)),"^",2) Q:'$L(MODNM) "-1^Invalid Modifier Name"
+ S MODI=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MODI) "-1^Invalid Modifier ID"
+ S MODST=$$VSTCM^ICPTMOD(MIEN,VDT) K STX S (STA,STI)=0 S CDT=($$DTBR^ICPTSUPT(VDT))+.001
+ S RIEN=0 F  S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0  D
+ . S ND=$G(^DIC(81.3,MIEN,10,RIEN,0))
+ . S BEGR=$P(ND,"^",1),BEGA=$S(BEGR?1N.4N:+BEGR,BEGR?4N1A:$A($E(BEGR,5))*10_$E(BEGR,1,4),1:$A(BEGR)_$E(BEGR,2,5)) Q:CODEA<BEGA
+ . S ENDR=$P(ND,"^",2),ENDA=$S(ENDR?1N.4N:+ENDR,ENDR?4N1A:$A($E(ENDR,5))*10_$E(ENDR,1,4),1:$A(ENDR)_$E(ENDR,2,5)) Q:CODEA>ENDA
+ . S (ACD,ADT)=$P(ND,"^",3),(ICD,IDT)=$P(ND,"^",4) S:ADT="" ADT=2890101 S:'$L(IDT) IDT=$$FMADD^XLFDT($$DT^XLFDT,365)
+ . S NN="^DIC(81.3,"_MIEN_",10,"_RIEN_",0)"
+ . S STA=+($G(STA))+1,STX(STA)=MIEN_"^"_MODST_"^"_BEGR_"^"_ENDR_"^"_ADT_"^"_ICD_"^"_MODI,STX("B",+ADT,+STA)=""
+ S ADT=$O(STX("B",+CDT),-1),STA=$O(STX("B",+ADT," "),-1),MOD=$G(STX(+STA)) Q:+MOD'>0 "0"
+ Q MOD
+ ;
 MODC(MOD) ; Checks modifier for range including code
  D MODC^ICPTMOD2($G(MOD))
  Q
+ ;
 MULT ; Finds Duplicate Modifiers
  D MULT^ICPTMOD2 Q
-CODEN(CODE)    ; Return the IEN of a CPT modifier CODE
+ ;
+CODEN(CODE)    ; Return the IEN of a CPT modifier
+ ;   Input:  CPT modifier code
+ ;  Output:  IEN
+ ;
  Q:$G(CODE)="" -1
  N COD S COD=+$O(^DIC(81.3,"BA",(CODE_" "),0))
  Q $S(COD>0:COD,1:-1)
+ ;
 VSTCM(IEN,VDATE) ; Versioned Short Text (CPT Modifier)
  N CPT0,CPTC,CPTI,CPTSTD,CPTSTI,CPTVDT,CPTTXT,CPTTD,CPTTI
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD2.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD2.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTMOD2.m	(revision 636)
@@ -1,13 +1,8 @@
-ICPTMOD2 ;ALB/DEK/KER - CPT MODIFIER APIS ;08/18/2007
- ;;6.0;CPT/HCPCS;**30,37**;May 19, 1997;Build 25
- ;             
- ; Global Variables
- ;    ^DIC(81.3
- ;    ^ICPT(
- ;             
+ICPTMOD2 ; ALB/DEK/KER - CPT MODIFIER APIS ; 09/06/2006
+ ;;6.0;CPT/HCPCS;**30**;May 19, 1997;Build 1
+ ;
  ; External References
- ;    $$DT^XLFDT       DBIA  10103
- ;    $$FMADD^XLFDT    DBIA  10103
- ;             
+ ;   DBIA  10103  $$DT^XLFDT
+ ;
  Q
 MODA ; Create an array of Modifiers for a CPT Code
@@ -49,70 +44,11 @@
  . S (EFF,ST)=$O(^DIC(81.3,MIEN,60,"B"," "),-1) Q:ST'>0  S ST=$O(^DIC(81.3,MIEN,60,"B",ST," "),-1) Q:ST'>0  S ST=$P($G(^DIC(81.3,MIEN,60,ST,0)),"^",2) Q:ST'>0
  . S MOD=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MOD)
- . S X=$$MODP(CODE,MIEN,"I",VDT,0) S ID=$P(X,"^",6) S ID=$S(+ID>0:"I",1:"A")
+ . S X=$$MODP^ICPTMOD(CODE,MIEN,"I",VDT,0) S ID=$P(X,"^",6) S ID=$S(+ID>0:"I",1:"A")
  . S:+X>0 ARY(ID,MOD)=$P(X,"^",1,2)_"^"_EFF_"^"_$P(X,"^",3,7)
  S (A,I)=0,ST="" F  S ST=$O(ARY(ST)) Q:ST=""  S MOD="" F  S MOD=$O(ARY(ST,MOD)) Q:MOD=""  S:ST="A" A=A+1 S:ST="I" I=I+1
  S ST=A+I,ARY(0)=ST_"^"_A_"^"_I_"^"_CODE
  Q
- ;            
-MODP(CODE,MOD,MFT,MDT,SRC,DFN) ;  Check if modifier can be used with code (pair)
  ;
- ; Input:
- ; 
- ;    CODE   CPT/HCPCS Code ?7N / ?1A4N / ?4N1A
- ;    MOD    Modifier (External or Internal)
- ;    MFT    Modifier Format "E" - or "I"
- ;    VDT    Date service provided
- ;    SRC    Source Screen
- ;               If 0 or Null, Level I and II modifiers
- ;               If >0, Level I, II, and III modifiers
- ; Output:
- ;
- ;    If pair is acceptable - Positive "^" Delimited String
- ;        
- ;        1 - IEN of CPT Modifier
- ;        2 - Versioned Short Text
- ;        3 - Beginning Code for Code Range
- ;        4 - Ending Code for Code Range
- ;        5 - Code Range Activaiton Date
- ;        6 - Code Range Inactivation Date
- ;        7 - Modifier Identifier
- ;        
- ;    If pair is unacceptable
- ;    
- ;        0 or
- ;       -1 with error message
- ;  
- N ADT,BEGA,BEGR,CDT,CODEA,CODN,ENDA,ENDR,ICD,IDT,LACT,LINA,MIEN,MODEFF,MODI,MODNM,MODST,ND,NSTA,RIEN,RSTA,SIEN,STA,STI,STX,TA,TEFF,TI,TIEN,VDT
- S:$G(MFT)="" MFT="E" Q:"^E^I^"'[("^"_MFT_"^") "-1^Invalid Modifier Format"  S VDT=$P($G(MDT),".",1)
- S:+VDT'?7N VDT=$$DT^XLFDT S:VDT#10000=0 VDT=VDT+101 S:VDT#100=0 VDT=VDT+1 S VDT=$S(VDT<2890101:2890101,1:VDT)
- Q:+VDT'>0!(VDT'?7N) "-1^Invalid Date"  I MFT="E" D  I +($G(MIEN))'>0 Q "-1^Multiple Modifiers with the same name, use IEN"
- . S MIEN=0 S (TIEN,TI)=0 F  S TIEN=$O(^DIC(81.3,"B",MOD,TIEN)) Q:+TIEN'>0  D
- . . S TEFF=$$EFF^ICPTSUPT(81.3,TIEN,VDT) Q:'$P(TEFF,"^",2)  S TI=TI+1,TA(TI)=TIEN,TA(0)=TI
- . S:+($G(TA(0)))=1 MIEN=+($G(TA(1)))
- S:MFT="I" MIEN=+MOD S CODE=$G(CODE),CODN=$S(CODE?1.N:+CODE,1:$$CODEN^ICPTCOD(CODE)) I CODN<1!'$D(^ICPT(CODN,0)) Q "-1^NO SUCH CPT CODE"
- S CODE=$P($G(^ICPT(CODN,0)),"^") Q:'$L(CODE) "-1^No such CPT Code"  Q:$L(CODE)'=5 "-1^Invalid Code"
- S CODEA=$S(CODE?1N.4N:+CODE,CODE?4N1A:$A($E(CODE,5))*10_$E(CODE,1,4),1:$A(CODE)_$E(CODE,2,5)) Q:+CODEA'>0 "-1^Invalid Code Source"
- S MIEN=$G(MIEN) Q:+MIEN'>0 "-1^Invalid Modifier"  S SRC=$S(+($G(SRC))>0:1,1:0),SIEN=$O(^ICPT("BA",(CODE_" "),0)) Q:+SIEN'>0 "-3^Invalid Code"
- Q:$P($G(^ICPT(+SIEN,0)),"^",6)="L"&(SRC'>0) "-1^Invalid Code Source"
- S MODEFF=$$EFF^ICPTSUPT(81.3,MIEN,VDT) Q:'$P(MODEFF,"^",2) "-1^Modifier Inactive"
- S MODNM=$P($G(^DIC(81.3,MIEN,0)),"^",2) Q:'$L(MODNM) "-1^Invalid Modifier Name"
- S MODI=$P($G(^DIC(81.3,MIEN,0)),"^",1) Q:'$L(MODI) "-1^Invalid Modifier ID"
- S MODST=$$VSTCM^ICPTMOD(MIEN,VDT) K STX S (STA,STI)=0 S CDT=VDT+.001
- S (LINA,LACT)="",RSTA=0,RIEN=0 F  S RIEN=$O(^DIC(81.3,MIEN,10,RIEN)) Q:+RIEN'>0  D
- . N NSTA S NSTA=0,ND=$G(^DIC(81.3,MIEN,10,RIEN,0))
- . S BEGR=$P(ND,"^",1) Q:$L(BEGR)'=5  S BEGA=$S(BEGR?1N.4N:+BEGR,BEGR?4N1A:$A($E(BEGR,5))*10_$E(BEGR,1,4),1:$A(BEGR)_$E(BEGR,2,5)) Q:+CODEA<+BEGA
- . S ENDR=$P(ND,"^",2) S:$L(ENDR)'=5 ENDR=BEGR S ENDA=$S(ENDR?1N.4N:+ENDR,ENDR?4N1A:$A($E(ENDR,5))*10_$E(ENDR,1,4),1:$A(ENDR)_$E(ENDR,2,5))
- . Q:$L(ENDR)&(CODEA>ENDA)  S ADT=$P(ND,"^",3),(ICD,IDT)=$P(ND,"^",4) S:ADT="" ADT=2890101
- . I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT'>0 S RSTA=1,NSTA=1 S:+ADT>0&(+ADT>(+LACT)) LACT=+ADT
- . I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT>0,CDT>ADT,CDT'>IDT S RSTA=1,NSTA=1 S:+ADT>0&(+ADT>(+LACT)) LACT=+ADT
- . I +CODEA'<+BEGA,+CODEA'>ENDA,+ADT>0,+IDT>0 S:+IDT>0&(+IDT>(+LINA)) LINA=+IDT
- . Q:NSTA'>0  S:'$L(IDT) IDT=$$FMADD^XLFDT($$DT^XLFDT,365) S ADT=$P(ND,"^",3),(ICD,IDT)=$P(ND,"^",4) S:ADT="" ADT=2890101
- . S:'$L(IDT) IDT=$$FMADD^XLFDT($$DT^XLFDT,365) S STA=+($G(STA))+1,STX(STA)=MIEN_"^"_MODST_"^"_BEGR_"^"_ENDR_"^"_ADT_"^"_ICD_"^"_MODI,STX("B",+ADT,+STA)=""
- S:+LACT>0&(+LINA>0)&(LINA'>CDT)&(+LINA>+LACT) RSTA=0
- S ADT=$O(STX("B",+CDT),-1),STA=$O(STX("B",+ADT," "),-1),MOD=$G(STX(+STA))
- Q:+MOD'>0 "0"  Q:+RSTA'>0 "0"
- Q MOD
- ;            
-MODC(MOD) ; Checks modifier for active range including code
+MODC(MOD) ; Checks modifier for range including code, and active for date desired
  ;
  ; Input:
@@ -132,7 +68,6 @@
  ;
 MULT ; Finds iens for all modifiers with same 2-letter code
- ;  MOD = .01, check B x-ref for dupliate .01 fields
- ;  Output:
- ;     STR - a ";" delimited string of IENS for modifier MOD
+ ;  MOD = .01, check B x-ref for other mods with equivalent .01 fields
+ ;  output concatenates ien of each mod to STR, separated by ":"
  F MODN=0:0 S MODN=$O(^DIC(81.3,"B",MOD,MODN)) Q:'MODN   S STR=STR_MODN_"; "
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTPRN.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTPRN.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTPRN.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTPRN ;ALB/MTC,RMO,ABR,MRY - CPT PRINT-OUT DRIVER ; 1/03/03 3:21pm
- ;;6.0;CPT/HCPCS;**4,8,9,12,13**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**4,8,9,12,13**;May 19, 1997;Build 1
  ;
  ;modified to sort in code name order using temp global;abr 1/96
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR1.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR1.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR1.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR1 ;ALB/ABR,MRY - CPT IENS - REV CPT CODES ; 1/3/03 2:38pm
- ;;6.0;CPT/HCPCS;**3,4,8,9,12,13**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**3,4,8,9,12,13**;May 19, 1997;Build 1
  ;
  ;  This routine points to the ien's of the REVISED CPT codes for 2003
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR10.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR10.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR10.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR10 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR11.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR11.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR11.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR11 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR12.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR12.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR12.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR12 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR13.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR13.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR13.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR13 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR14.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR14.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR14.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR14 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR15.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR15.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR15.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR15 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR16.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR16.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR16.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR16 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR17.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR17.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR17.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR17 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR18.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR18.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR18.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR18 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR19.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR19.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR19.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR19 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR2.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR2.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR2.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR2 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**3,4,8,9,12,13**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**3,4,8,9,12,13**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR20.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR20.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR20.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR20 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR21.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR21.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR21.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR21 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR22.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR22.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR22.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR22 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR23.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR23.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR23.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR23 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR24.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR24.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR24.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR24 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR3.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR3.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR3.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR3 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**8,9,12,13**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**8,9,12,13**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR4.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR4.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR4.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR4 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1 ; 1/28/02 4:17pm
- ;;6.0;CPT/HCPCS;**8,9,12**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**8,9,12**;May 19, 1997;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR5.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR5.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR5.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR5 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR6.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR6.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR6.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR6 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR7.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR7.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR7.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR7 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR8.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR8.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR8.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR8 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR9.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR9.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSR9.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSR9 ;CPT CODES - ICPTSRx DATA FILE FOR ICPTSR1
- ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001
+ ;;6.0;CPT/HCPCS;**9,12**;Feb 27, 2001;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSUPT.m
===================================================================
--- FOIAVistA/trunk/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSUPT.m	(revision 631)
+++ FOIAVistA/tag/r/CPT_HCPCS_CODES-ICPT-DGYA/ICPTSUPT.m	(revision 636)
@@ -1,4 +1,4 @@
 ICPTSUPT ;SLC/KER - CPT SUPPORT FOR APIS ; 04/18/2004
- ;;6.0;CPT/HCPCS;**14,19**;May 19, 1997
+ ;;6.0;CPT/HCPCS;**14,19**;May 19, 1997;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/DENTAL-DEN/DENTA14.m
===================================================================
--- FOIAVistA/trunk/r/DENTAL-DEN/DENTA14.m	(revision 631)
+++ FOIAVistA/tag/r/DENTAL-DEN/DENTA14.m	(revision 636)
@@ -1,4 +1,24 @@
 DENTA14 ;ISC2/SAW,HAG-TREATMENT DATA REPORT - INDIVIDUAL SITTINGS ;3/29/88
- ;;1.2;DENTAL;**16,19**;JAN 26, 1989
+ ;;1.2;DENTAL;**16,19**;JAN 26, 1989;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
+ ;  3080129 - RCR - The Variable, DENTSD is an input
+ ;  DENTSD -  This is a Variable that is established before this routine is called.
  ;VERSION 1.2
  S DENTC=0,DENTSD=DENTSD-.0001,%ZIS="MQ" K IO("Q") D ^%ZIS G EXIT1:IO=""
@@ -7,10 +27,14 @@
 RPT F I=0:1 S DENTSD=$O(^DENT(221,"A1",DENTSTA,DENTSD)) Q:DENTSD>DENTED!(DENTSD="")  D:'I HDR^DENTA16 S DENT="" F J=0:0 S DENT=$O(^DENT(221,"A1",DENTSTA,DENTSD,DENT)) Q:DENT=""  I $D(^DENT(221,DENT,0)) S X=^(0) D HDR1 Q:Z5=U  D P1 Q:Z5=U
  Q
-P1 I $D(DENTREL) Q:'$D(^DENT(221,DENT,1))  S Y(1)=$P(^(.1),"^",2) I 'Y(1)!<DENTSD1!Y(1)>DENTED Q
+ ;  P1 I $D(DENTREL) Q:'$D(^DENT(221,DENT,1))  S Y(1)=$P(^(.1),"^",2) I 'Y(1)!<DENTSD1!Y(1)>DENTED Q
+ ; The expression on the comment above is wrong.  I suspect that the meaning is that Y(1) needs to be
+ ;   at, or between DENTSD1 and DENTED.  This test below will filter out the outer extremes.
+ ;
+P1 I $D(DENTREL) Q:'$D(^DENT(221,DENT,1))  S Y(1)=$P(^(.1),"^",2) I Y(1)<DENTSD1!(Y(1)>DENTED) Q
  S DENTC=DENTC+1 D CHK^DENTA15 Q:DENTF
  I $P(X,U,27) S K=$S($P(X,U,27)=1:35,1:37) W ?46,$E($P(^DIC(220.3,K,0),U,1),1,30),?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q
  I $P(X,U,44) W ?46,$E($P(^DIC(220.3,36,0),U,1),1,30),?79,1,! W:$P(X,U,45) ?46,$E($P(^DIC(220.3,38,0),U,1),1,30),?79,$P(X,U,45),! D:IOSL-($Y#IOSL)<4 HOLD1 Q
  I $P(X,U,41) W ?46,$E($P(^DIC(220.3,$P(X,U,41),0),U,1),1,30),?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U
- I $P(X,U,8) W ?46,"ADMINISTRATIVE PROCEDURE",?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U
+ I $P(X,U,8)  W ?46,"ADMINISTRATIVE PROCEDURE",?79,1,!                D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U
  I $P(X,U,7)'="" S X(2)=$S($P(X,U,7)="S":"4",1:"5") W ?46,$E($P(^DIC(220.3,X(2),0),U,1),1,30),?79,1,! D:IOSL-($Y#IOSL)<4 HOLD1 Q:Z5=U
  F K=9,11:1:18,20,22:1:26,28:1:38,42:1:43 I $P(X,U,K) D W Q:Z5=U
Index: FOIAVistA/tag/r/DIETETICS-FH/FHASP1.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHASP1.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHASP1.m	(revision 636)
@@ -1,4 +1,4 @@
 FHASP1 ; HISC/REL/JH - Nutrition Profile (cont) ;5/2/01  10:14
- ;;5.5;DIETETICS;**8,9**;Jan 28, 2005;Build 7
+ ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
  ;
  I '$G(FHET) S X="T-365",%DT="XT" D ^%DT S FHET=Y K %DT
@@ -63,5 +63,5 @@
  F KK=35:-1:1 Q:$E(X,KK-1,KK)=", "
  W $E(X,1,KK-2) S X=$E(X,KK+1,999) Q
-SP Q:'$P(X,U)  S M1=$P(X,"^",2) S:M1="A"!(M1="") M1="BNE" S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!($P(Z,U,2)="")  S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4)
+SP Q:'$P(X,U)  S M1=$P(X,"^",2) S:M1="A" M1="BNE" S Z=$G(^FH(115.2,+X,0)) Q:$P(Z,U)=""!($P(Z,U,2)="")  S L1=$P(Z,"^",1),KK=$P(Z,"^",2),M="",DAS=$P(X,"^",4)
  I KK="L" S Q=$P(X,"^",3),L1=$S(Q:Q,1:1)_" "_L1
  I M1="BNE" S M="1~All Meals" G SP1
Index: FOIAVistA/tag/r/DIETETICS-FH/FHDSSAPI.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHDSSAPI.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHDSSAPI.m	(revision 636)
@@ -1,4 +1,4 @@
-FHDSSAPI ;Hines OIFO/RTK,JRC-DSS REQUESTED API's  ;11/23/07 12:40pm
- ;;5.5;DIETETICS;**7,11,10**;Jan 28, 2005;Build 5
+FHDSSAPI ;Hines OIFO/RTK-DSS REQUESTED API's  ;3/08/06  10:15
+ ;;5.5;DIETETICS;**7,11**;Jan 28, 2005;Build 4
  ;11/22/2006 KAM/BAY Remedy Call 168346 Add Variable Cleanup from *7
  ;
@@ -9,47 +9,28 @@
  I FHSDT>FHEDT W !!,"END DATE BEFORE START DATE!",! H 1 Q
  K ^TMP($J,"FH") S FHEDT=FHEDT_.99
- F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0  F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0  D
- .I '$D(^FHPT(FHDFN,0)) Q
- .; Quit if patient is deceased - DSS developer added lines DATA+9,10,13
- .S FHDCEASE=$$GET1^DIQ(2,$P(^FHPT(FHDFN,0),U,3),".351","I")
- .Q:FHDCEASE&(FHDCEASE<FHSDT)
- .S FHZN=$G(^FHPT(FHDFN,"A",FHADM,0)),FHLAST=""
- .S FHADTM=$P(FHZN,U,1) I FHADTM>FHEDT Q
- .I '$P(FHZN,U,14),FHDCEASE S $P(FHZN,U,14)=FHDCEASE
- .S FHDDTM=$P(FHZN,U,14) I FHDDTM'="",FHDDTM<FHSDT Q
- .F FHDATE=0:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT)  D
- ..S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2)
- ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0))
- ..I FHDATE<FHSDT I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"INP")
- ..S FHLAST=FHDATE
- ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"INP")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
- .; Get additional feedings for inpatient
- .F FHDATE=0:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"EL",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT)  D
- ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHDATE,0))
- ..I FHDATE<FHSDT Q  I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"EL")
- ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"EL")=FHNODE
- .S FHLAST="" F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHSF)) Q:FHSF'>0  D
- ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0))
- ..S FHDATE=$P(FHNODE,U,2) I FHDATE>FHEDT Q
- ..S FHCDATE=$P(FHNODE,U,32) I FHCDATE'="" I FHCDATE<FHSDT Q
- ..I FHDATE<FHSDT I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"SF")
- ..S FHLAST=FHDATE
- ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"SF")=FHNODE
- .S FHNUM=0 F FHSO=0:0 S FHSO=$O(^FHPT(FHDFN,"A",FHADM,"SP",FHSO)) Q:FHSO'>0  D
- ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0))
- ..S FHDATE=$P(FHNODE,U,4) I FHDATE>FHEDT Q
- ..S FHCDATE=$P(FHNODE,U,6) I FHCDATE'="" I FHCDATE<FHSDT Q
- ..S FHNUM=FHNUM+1,^TMP($J,"FH",FHADM,FHDFN,FHDATE,"SO",FHNUM)=FHNODE
- .S FHLAST="" F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF)) Q:FHTF'>0  D
- ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0))
- ..S FHDATE=$P(FHNODE,U,1) I FHDATE>FHEDT Q
- ..S FHCDATE=$P(FHNODE,U,11) I FHCDATE'="" I FHCDATE<FHSDT Q
- ..I FHDATE<FHSDT I FHLAST'="" K ^TMP($J,"FH",FHADM,FHDFN,FHLAST,"TF")
- ..S FHLAST=FHDATE
- ..S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"TF")=FHNODE
+ F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0  F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:FHADM'>0  F FHDATE=FHSDT:0 S FHDATE=$O(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE)) Q:FHDATE'>0!(FHDATE>FHEDT)  D
+ .S FHDSEQ=$P($G(^FHPT(FHDFN,"A",FHADM,"AC",FHDATE,0)),U,2)
+ .S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"DI",FHDSEQ,0))
+ .S ^TMP($J,"FH",FHDATE,FHDFN,FHADM,"INP")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
+ ; Get additional feedings for inpatient
+ F FHDFN=0:0 S FHDFN=$O(^FHPT(FHDFN)) Q:FHDFN'>0  F FHADM=0:0 S FHADM=$O(^FHPT(FHDFN,"A",FHADM)) Q:'FHADM  D
+ .F FHEL=FHSDT:0 S FHEL=$O(^FHPT(FHDFN,"A",FHADM,"EL",FHEL)) Q:FHEL'>0!(FHEL>FHEDT)  D
+ ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"EL",FHEL,0))
+ ..S ^TMP($J,"FH",FHEL,FHDFN,FHADM,"EL")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
+ .F FHSF=0:0 S FHSF=$O(^FHPT(FHDFN,"A",FHADM,"SF",FHSF)) Q:FHSF'>0  D
+ ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SF",FHSF,0)),FHSFDT=$P(FHNODE,U,2)
+ ..I FHSFDT<FHSDT!(FHSFDT>FHEDT) Q
+ ..S ^TMP($J,"FH",FHSFDT,FHDFN,FHADM,"SF")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
+ .F FHSO=0:0 S FHSO=$O(^FHPT(FHDFN,"A",FHADM,"SP",FHSO)) Q:FHSO'>0  D
+ ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"SP",FHSO,0)),FHSODT=$P(FHNODE,U,4)
+ ..I FHSODT<FHSDT!(FHSODT>FHEDT) Q
+ ..S ^TMP($J,"FH",FHSODT,FHDFN,FHADM,"SO")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
+ .F FHTF=0:0 S FHTF=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF)) Q:FHTF'>0  D
+ ..S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,0)),FHTFDT=$P(FHNODE,U,1)
+ ..I FHTFDT<FHSDT!(FHTFDT>FHEDT) Q
+ ..S ^TMP($J,"FH",FHTFDT,FHDFN,FHADM,"TF")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
  ..F FHTFPR=0:0 S FHTFPR=$O(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR)) Q:FHTFPR'>0  D
  ...S FHNODE=$G(^FHPT(FHDFN,"A",FHADM,"TF",FHTF,"P",FHTFPR,0))
- ...S ^TMP($J,"FH",FHADM,FHDFN,FHDATE,"TF",FHTFPR,"P")=FHNODE
- ...Q
+ ...S ^TMP($J,"FH",FHTFDT,FHDFN,FHADM,"TF",FHTFPR,"P")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
  ..Q
  .Q
@@ -59,5 +40,4 @@
  F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("RM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT)  D
  .F FHDFN=0:0 S FHDFN=$O(^FHPT("RM",FHOMDT,FHDFN)) Q:FHDFN=""  D
- ..I '$D(^FHPT(FHDFN,0)) Q
  ..F FHRNUM=0:0 S FHRNUM=$O(^FHPT("RM",FHOMDT,FHDFN,FHRNUM)) Q:FHRNUM=""  D
  ...S FHNODE=$G(^FHPT(FHDFN,"OP",FHRNUM,0)) I $P(FHNODE,U,15)="C" Q
@@ -65,5 +45,5 @@
  ...S ^TMP($J,"FH",FHOMDT,FHDFN,FHRNUM,"RM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
  ...;
- ...; IF NON-VA LOC DIET(S) ARE IN FIELDS DIET1-DIET5
+ ...; SHOULD LET DSS KNOW DIETS COULD BE IN FIELDS DIET1-5 IF NONVA LOC
  ...;
  ...I $D(^FHPT(FHDFN,"OP",FHRNUM,2)) D
@@ -81,5 +61,4 @@
  F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("SM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT)  D
  .F FHDFN=0:0 S FHDFN=$O(^FHPT("SM",FHOMDT,FHDFN)) Q:FHDFN=""  D
- ..I '$D(^FHPT(FHDFN,0)) Q
  ..S FHNODE=$G(^FHPT(FHDFN,"SM",FHOMDT,0)) I $P(FHNODE,U,2)'="A" Q
  ..I $P($G(^FHPT(FHDFN,0)),U,3)="" Q
@@ -88,10 +67,8 @@
  F FHOMDT=FHSDTX1:0 S FHOMDT=$O(^FHPT("GM",FHOMDT)) Q:FHOMDT=""!(FHOMDT'<FHEDT)  D
  .F FHDFN=0:0 S FHDFN=$O(^FHPT("GM",FHOMDT,FHDFN)) Q:FHDFN=""  D
- ..I '$D(^FHPT(FHDFN,0)) Q
  ..S FHNODE=$G(^FHPT(FHDFN,"GM",FHOMDT,0)) I $P(FHNODE,U,9)="C" Q
  ..I $P($G(^FHPT(FHDFN,0)),U,3)="" Q
  ..S ^TMP($J,"FH",FHOMDT,FHDFN,"GM")=FHNODE I '$D(^TMP($J,"FH","ZN",FHDFN)) S ^TMP($J,"FH","ZN",FHDFN)=^FHPT(FHDFN,0)
  K FHADM,FHDATE,FHDFN,FHDSEQ,FHEL,FHNODE,FHNODE2,FHNODE3,FHOMDT,FHRNUM
- K FHSDTX1,FHSF,FHSFDT,FHSO,FHSODT,FHTF,FHTFDT,FHTFPR,FHTUZN,FHZ,FHZN
- K FHCDATE,FHNUM,FHEFF,FHADTM,FHDDTM,FHLAST,X,X1,X2,FHDCEASE
+ K FHSDTX1,FHSF,FHSFDT,FHSO,FHSODT,FHTF,FHTFDT,FHTFPR,FHTUZN,FHZ,X,X1,X2
  Q
Index: FOIAVistA/tag/r/DIETETICS-FH/FHNO2.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHNO2.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHNO2.m	(revision 636)
@@ -1,4 +1,4 @@
 FHNO2 ; HISC/REL/NCA - Supplemental Feeding Labels ;8/26/94  12:01 
- ;;5.5;DIETETICS;**5,13**;Jan 28, 2005;Build 1
+ ;;5.5;DIETETICS;**5**;Jan 28, 2005;Build 53
  ;patch #5 - add outpatient SFs.
 D0 R !!,"Select by S=SUPPLEMENTAL FEEDING SITE or W=WARD: ",XX:DTIME G:'$T!("^"[XX) KIL I "sw"[XX S X=XX D TR^FH S XX=X
@@ -89,8 +89,7 @@
  .S FHODAT=$G(^FHPT(FHDFN,"OP",ADM,0)),FHNO=$P($G(^FHPT(FHDFN,"OP",ADM,"SF",0)),U,3) Q:'$G(FHNO)
  .S FHMEAL=$P(FHODAT,U,4),FHOWARD=$P(FHODAT,U,3)
- .S X1=$G(^FH(119.6,FHOWARD,0))
+ .S X1=$G(^FH(119.6,FHOWARD,0)),WRDN=$P(X1,U,1)
  .Q:'FHOWARD!'$D(^FH(119.6,FHOWARD,0))
  .I XX="W",W1 Q:W1'=FHOWARD
- .S WRDN=$P(X1,U,1)
  .I XX="S" S D2=$P(X1,"^",9) Q:D1'=D2  I D1=D2 S P0=$P(X1,"^",4),P0=$S(P0<1:99,P0<10:"0"_P0,1:P0)
  .S P1=$S(FHMEAL="N":13,FHMEAL="E":21,1:5)
Index: FOIAVistA/tag/r/DIETETICS-FH/FHOMPP.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHOMPP.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHOMPP.m	(revision 636)
@@ -1,4 +1,4 @@
-FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;7/2/2007
- ;;5.5;DIETETICS;**9**;Jan 28, 2005;Build 7
+FHOMPP ; OIFO/RTK - Patient Profile for Outpatients ;6/23/03  1:04
+ ;;5.5;DIETETICS;;Jan 28, 2005
  D DEV Q
 DEV ;get device and set up queue
@@ -49,5 +49,5 @@
  ; Data is returned in ^TMP($J,"FHPROF",DFN,FHX)
  S FHZ115="P"_DFN D CHECK^FHOMDPA I FHDFN="" Q "-1^Invalid outpatient"
- K ^TMP($J,"FHPROF"),^TMP($J,"L"),^TMP($J,"D") S (FHX,N)=0 D PATNAME^FHOMUTL
+ K ^TMP($J,"FHPROF",DFN) S (FHX,N)=0 D PATNAME^FHOMUTL
  S FHB="" F I=1:1:80 S FHB=FHB_" "
  S ^TMP($J,"FHPROF",DFN,FHX)="OUTPATIENT NAME: "_FHPTNM_"   "_FHSSN
@@ -67,8 +67,8 @@
  I $D(^TMP($J,"L")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Likes"
  S FHM="" F  S FHM=$O(^TMP($J,"L",FHM)) Q:FHM=""  D
- .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0  S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP)
+ .F FHP=0:0 S FHP=$O(^TMP($J,"L",FHM,FHP)) Q:FHP'>0  S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"L",FHM,FHP) Q
  I $D(^TMP($J,"D")) S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Dislikes"
  S FHM="" F  S FHM=$O(^TMP($J,"D",FHM)) Q:FHM=""  D
- .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0  S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP)
+ .F FHP=0:0 S FHP=$O(^TMP($J,"D",FHM,FHP)) Q:FHP'>0  S N=0 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)=^TMP($J,"D",FHM,FHP) Q
  ;
  S N=1 D NEWL S ^TMP($J,"FHPROF",DFN,FHX)="Recurring Meals on File: "
Index: FOIAVistA/tag/r/DIETETICS-FH/FHORC5.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHORC5.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHORC5.m	(revision 636)
@@ -1,10 +1,8 @@
 FHORC5 ; HISC/REL - Consult Management ;4/12/06  13:26
- ;;5.5;DIETETICS;**4,12**;Jan 28, 2005;Build 3
- ; 10/17/2007 BP/KAM FH*5.5*12 Rem Call 210883 Remove Old Clinician Field (#1)
+ ;;5.5;DIETETICS;**4**;Jan 28, 2005;Build 32
 EN9 ; Enter/Edit Ward Assignments
  K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQM"
  W ! D ^DIC G KIL:U[X!$D(DTOUT),EN9:Y<1 S OLD=$S($P(Y,"^",3):"",1:$P(^FH(119.6,+Y,0),"^",2))
- ; 10/17/2007 BP/KAM *12 Rem Call 210883 Removed field #1 in next line
- S DA=+Y,DR="112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9
+ S DA=+Y,DR="1;112" D ^DIE S NEW=$P(^FH(119.6,DA,0),"^",2) I 'NEW!('OLD) K OLD,NEW,X,Y G EN9
  D:OLD'=NEW EN2^FHORC4 K OLD,NEW,X,Y G EN9
 EN10 ; List Ward Assignments
Index: FOIAVistA/tag/r/DIETETICS-FH/FHPRO.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHPRO.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHPRO.m	(revision 636)
@@ -1,10 +1,7 @@
 FHPRO ; HISC/REL/RTK - Food Production Manager ;4/12/06  15:53
- ;;5.5;DIETETICS;**4,5,12**;Jan 28, 2005;Build 3
- ;
- ; 10/16/2007 BY/KAM FH*5.5*12 Rem Call 210883 Remove access to old
- ;                             Clinician field
+ ;;5.5;DIETETICS;**4,5**;Jan 28, 2005;Build 53
 EN2 ; Enter/Edit Nutrition Locations (Inpatient Wards/Outpatient Clinics)
  W ! K DIR,DIC S DIR("A")="Select WARD or OUTPATIENT Location: "
- S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR I $D(DIRUT) G KIL
+ S DIR(0)="SAO^W:Ward Location;O:Outpatient Location" D ^DIR Q:$D(DIRUT)
  I Y'=-1 S FHANS=Y
  I FHANS="W" D EN2WRD Q
@@ -14,7 +11,5 @@
  K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6
  S DIC("DR")=".01" W ! D ^DIC K DIC,DLAYGO G KIL:U[X!$D(DTOUT),EN2:Y<1
- ; S DR=".01;2:2.5;... POTENTIAL CHG FOR 210883 WAS S DR=".01:2.5;3"
- ; 10/16/2007 BP/KAM FH*5.5*12 changed next line to remove access to field # 1 Clinician (Old Clinician field)
- S DA=+Y,DR=".01;2:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2
+ S DA=+Y,DR=".01:2.5;3;S:X="""" Y=4;3.5;4;S:X="""" Y=5;4.5;5;S:'X Y=6;5.5;6:29;99;107;107.5;108;108.5;109;109.5;110;110.5;111;111.5;112" S:$D(^XUSEC("FHMGR",DUZ)) DIDEL=119.6 D ^DIE,KIL G EN2
 EN2OL ;Outpatient locations
  K DIC S (DIC,DIE)="^FH(119.6,",DIC(0)="AEQLM",DLAYGO=119.6
Index: FOIAVistA/tag/r/DIETETICS-FH/FHPRW.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHPRW.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHPRW.m	(revision 636)
@@ -1,5 +1,4 @@
 FHPRW ;Hines OIFO/REL,RTK - List Dietetic Locations ;5/13/94  14:57 
- ;;5.5;DIETETICS;**12**;Jan 28, 2005;Build 3
- ; 10/24/07 BAY/KAM FH*5.5*12 CALL 214407 Display new Clinician Field
+ ;;5.5;DIETETICS;;Jan 28, 2005
 F1 R !!,"Select LOCATION (or ALL): ",X:DTIME G:'$T!("^"[X) KIL D:X="all" TR^FH I X="ALL" S WRD=0
  E  K DIC S DIC="^FH(119.6,",DIC(0)="EQM" D ^DIC K DIC G:Y<1 F1 S WRD=+Y
@@ -16,10 +15,5 @@
  W !!,"Print Order:",?22,$P(X,"^",4)
  W !,"Type of Location:",?22,$S($P(X,U,3)="O":"OUTPATIENT",1:"INPATIENT")
- ;
- ;10/24/07 BAY/KAM *12 214407 Print new Clinician Multiple field
- N C1 S C1=""
- F  S C1=$O(^FH(119.6,K1,2,C1)) Q:C1=""  D
- .  S Z=$G(^FH(119.6,K1,2,C1,0)) I Z W !,"Assigned Clinician(s):",?22,$P($G(^VA(200,Z,0)),"^",1)
- ;
+ W !,"Assigned Clinician:",?22 S Z=$P(X,"^",2) I Z W $P($G(^VA(200,Z,0)),"^",1)
  W !,"Tray Assembly:",?22 S Z=$P(X,"^",5) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",17) S:Z="" Z=100 W "   (",Z,"%)"
  W !,"Cafeteria:",?22 S Z=$P(X,"^",6) I Z W $P($G(^FH(119.72,Z,0)),"^",1) S Z=$P(X,"^",18) S:Z="" Z=100 W "   (",Z,"%)"
Index: FOIAVistA/tag/r/DIETETICS-FH/FHREP1.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHREP1.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHREP1.m	(revision 636)
@@ -1,4 +1,4 @@
 FHREP1 ; HISC/NCA - Inventory Worksheet and Report ;3/9/95  08:28
- ;;5.5;DIETETICS;**13**;Jan 28, 2005;Build 1
+ ;;5.5;DIETETICS;;Jan 28, 2005
 EN2 ; Print the Inventory Worksheet & Report
  S FHXX="F"
@@ -10,5 +10,5 @@
  K %DT W !!,"Enter Mth/Yr: "_+$E(NOW,4,5)_"/"_$E(NOW,2,3)_"// " R X:DTIME G:'$T!(X["^") KIL^FHREP
  I X="" S X=$E(NOW,1,5)_"00"
- S %DT="M" D ^%DT K %DT I Y<1!($E(Y,1,5)>$E(NOW,1,5)) W *7,"  Answer Month and Yr as Mth/Yr or Mth Yr.",!?25,"   CANNOT be greater than now." G E0
+ D ^%DT I Y<1!($E(Y,1,5)>$E(NOW,1,5)) W *7,"  Answer Month and Yr as Mth/Yr or Mth Yr.",!?25,"   CANNOT be greater than now." G E0
  S MTH=+$E(Y,4,5),MTH=$P("January February March April May June July August September October November December"," ",MTH),YR=$E(Y,2,3),MTH=MTH_" "_YR
  I FHR="W" D F1^FHREP G:FHXX["^"!("^"[X) KIL^FHREP
Index: FOIAVistA/tag/r/DIETETICS-FH/FHSELA1.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHSELA1.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHSELA1.m	(revision 636)
@@ -1,8 +1,4 @@
 FHSELA1 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007
- ;;5.5;DIETETICS;**8,12**;Jan 28, 2005;Build 3
- ;
- ;10/16/2007 BAY/KAM FH*5.5*12 Remedy Call 210385 Do not allow
- ;                             user to change Food Preference name or
- ;                             LIKE/DISLIKE field
+ ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
  ;
 CREATE ; Check for any missing Allergy-type FP's or one's not renamed in 115.2
@@ -42,6 +38,5 @@
  S X=FHAFPNM K DIC,DO
  S (DIC,DIE)="^FH(115.2,",DIC(0)="L" D FILE^DICN
- ; 10/16/2007 BP/KAM FH*5.5*12 Default DISLIKE and prevent Food Preference name change in the next line
- S (FHDA,DA)=+Y,DR="26;1////D"
+ S (FHDA,DA)=+Y,DR=".01;26;1//DISLIKE;S:X=""D"" Y=0;3;20;S:'X Y=99;21;99"
  D ^DIE K DA,DIE,DR
  D TRAN^FHSEL1
Index: FOIAVistA/tag/r/DIETETICS-FH/FHSELA2.m
===================================================================
--- FOIAVistA/trunk/r/DIETETICS-FH/FHSELA2.m	(revision 631)
+++ FOIAVistA/tag/r/DIETETICS-FH/FHSELA2.m	(revision 636)
@@ -1,4 +1,4 @@
 FHSELA2 ;Hines OIFO/RTK - Map GMR Allergy file to Food Prefs ;3/07/2007
- ;;5.5;DIETETICS;**8,13**;Jan 28, 2005;Build 1
+ ;;5.5;DIETETICS;**8**;Jan 28, 2005;Build 28
  ;
 TMPGL ; Create ^TMP Global
@@ -146,5 +146,5 @@
  ;;GREENS, MUSTARD;MUSTARD GREENS
  ;;GREENS, TURNIP;TURNIP GREENS
- ;;GREEN LEAFY VEG;GREEN LEAFY VEGETABLES
+ ;;GREEN LEAFY VEGETABLES;GREEN LEAFY VEGETABLES
  ;;GUAVA;GUAVA
  ;;HOMINY;HOMINY
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD0IDX.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD0IDX.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD0IDX.m	(revision 636)
@@ -1,4 +1,4 @@
 ICD0IDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
- ;;18.0;DRG Grouper;**6**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**6**;Oct 20, 2000;Build 1
  ;
  ; ICDCOD          ICD Code from Global
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD187PT.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD187PT.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD187PT.m	(revision 636)
@@ -1,4 +1,4 @@
 ICD187PT ; ALB/ADL - GROUPER DRIVER ; 04/11/03
- ;;18.0;DRG Grouper;**7**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1
  ;;**routine to build the new DRG global levels required for the CSV project
  ;;**taken from routine created by DEK to add new "66" levels to ICD0 and ICD9
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD18PR.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD18PR.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD18PR.m	(revision 636)
@@ -1,4 +1,4 @@
 ICD18PR ;ALB/ESD - DRG GROUPER 16 PRE-INSTALL ; 10/23/00 11:56am
- ;;18.0;DRG Grouper;;Oct 20, 2000
+ ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
  ;
  ;  This routine kills the ICD9 and ICD0 globals 
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD18PT.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD18PT.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD18PT.m	(revision 636)
@@ -1,4 +1,4 @@
 ICD18PT ;ALB/ESD - DRG V16 POST-INSTALL ; 10/23/00 11:57am
- ;;18.0;DRG Grouper;;Oct 20, 2000
+ ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
  ;
  ;
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD9IDX.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICD9IDX.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICD9IDX.m	(revision 636)
@@ -1,4 +1,4 @@
 ICD9IDX ;DLS/DEK - MUMPS Cross Reference Routine for History ; 04/28/2003
- ;;18.0;DRG Grouper;**6**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**6**;Oct 20, 2000;Build 1
  ;
  ; ICDCOD          ICD Code from Global
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDAPIU.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDAPIU.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDAPIU.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDAPIU ;DLS/DEK/KER - ICD UTILITIES FOR APIS ; 04/18/2004
- ;;18.0;DRG Grouper;**6,11,12,15**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**6,11,12,15**;Oct 20, 2000;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCOD.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDCOD.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCOD.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDCOD ;ALB/ABR/ADL - INQUIRE TO ICD CODES ; 10/23/00 11:36am
- ;;18.0;DRG Grouper;**7**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1
  ;;ADL;Update for CSV project - 03/20/03
  ;
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCODE.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDCODE.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDCODE.m	(revision 636)
@@ -1,4 +1,4 @@
-ICDCODE ;DLS/DEK/KER/FJF - ICD CODE APIS ; 09/20/07 8:54am
- ;;18.0;DRG Grouper;**6,12,14,29**;Oct 20, 2000;Build 18
+ICDCODE ;DLS/DEK/KER - ICD CODE APIS ; 10/20/04 8:54am
+ ;;18.0;DRG Grouper;**6,12,14**;Oct 20, 2000;Build 1
  ;
  ; External References
@@ -6,37 +6,34 @@
  ;
 ICDDX(CODE,CDT,DFN,SRC) ; Return ICD Dx Code Info
- ;Input:
- ;  CODE  Code/IEN (required)
- ;    CDT  Date (default = TODAY)
- ;    DFN  Not in use
- ;    SRC  Source
- ;         0 = exclude local codes
- ;         1 = include local codes
- ;
- ;Output:
- ;  Returns an 19 piece string delimited by ^
- ;    1  IEN of code in ^ICD9(
- ;    2  ICD-9 Dx Code (#.01)
- ;    3  Id (#2)
- ;    4  Versioned Dx (67 multiple)
- ;    5  Unacceptable as Principal Dx (#101)
- ;    6  Major Dx Cat (#5)
- ;    7  MDC13 (5.5)
- ;    8  Compl/Comorb (#70)
- ;    9  ICD Expanded (#8) 1:Yes 0:No
- ;    10 Status (66 multiple)
- ;    11 Sex (#9.5)
- ;    12 Inactive Date (66 multiple)
- ;    13 MDC24 (#5.7)
- ;    14 MDC25 (#5.9)
- ;    15 Age Low (#14)
- ;    16 Age High (#15)
- ;    17 Activation Date (.01 of 66 multiple)
- ;    18 Message
- ;    19 Versioned Complication/Comorbidity (#103)
- ;
- ;    or
- ;
- ;    -1^Error Description
+ ;Input:   CODE  Code/IEN (required)
+ ;         CDT   Date (default = TODAY)
+ ;         DFN   Not in use
+ ;         SRC   Source
+ ;               0 = exclude local codes
+ ;               1 = include local codes
+ ;
+ ;Output:  Returns an 18 piece string delimited by ^
+ ;           1  IEN of code in ^ICD9(
+ ;           2  ICD-9 Dx Code (#.01)
+ ;           3  Id (#2)
+ ;           4  Versioned Dx (67 multiple)
+ ;           5  Unacceptable as Principal Dx (#101)
+ ;           6  Major Dx Cat (#5)
+ ;           7  MDC13 (5.5)
+ ;           8  Compl/Comorb (#70)
+ ;           9  ICD Expanded (#8) 1:Yes 0:No
+ ;          10  Status (66 multiple)
+ ;          11  Sex (#9.5)
+ ;          12  Inactive Date (66 multiple)
+ ;          13  MDC24 (#5.7)
+ ;          14  MDC25 (#5.9)
+ ;          15  Age Low (#14)
+ ;          16  Age High (#15)
+ ;          17  Activation Date (.01 of 66 multiple)
+ ;          18  Message
+ ;
+ ;           or
+ ;
+ ;         -1^Error Description
  ;
  N DATA,EFF,INV,MDC,DRGFY
@@ -45,45 +42,41 @@
  I CODE<1 Q INV
  I '$D(^ICD9(CODE)) Q INV
- I '$G(SRC),$P(^ICD9(CODE,0),U,8) Q "-1^VA LOCAL CODE SELECTED"
+ I '$G(SRC),$P(^ICD9(CODE,0),"^",8) Q "-1^VA LOCAL CODE SELECTED"
  S DATA=$G(^ICD9(CODE,0)) I '$L(DATA) Q "-1^NO DATA"
  S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT))
  S EFF=$$EFF^ICDSUPT(80,CODE,CDT)
- S $P(DATA,U,6)=$$VMDC^ICDREF(CODE)
- S $P(DATA,U,9)=$S(EFF<1:0,1:$P(EFF,U))
- S $P(DATA,U,11)=$P(EFF,U,2),$P(DATA,U,16)=$P(EFF,U,3)
- S $P(DATA,U,3)=$$VSTD(CODE,CDT)
- S $P(DATA,U,17)=$$MSG^ICDAPIU(CDT)
- S $P(DATA,U,18)=$S($$COMCOM(CODE,CDT)'=-1:$$COMCOM(CODE,CDT),1:"")
- Q CODE_U_DATA
- ;
+ S $P(DATA,"^",6)=$$VMDC^ICDREF(CODE)
+ S $P(DATA,"^",9)=$S(EFF<1:0,1:$P(EFF,"^"))
+ S $P(DATA,"^",11)=$P(EFF,"^",2),$P(DATA,"^",16)=$P(EFF,"^",3)
+ S $P(DATA,"^",3)=$$VSTD(CODE,CDT)
+ Q CODE_"^"_DATA_"^"_$$MSG^ICDAPIU(CDT)
+ ;           
 ICDOP(CODE,CDT,DFN,SRC) ; Return ICD Operation/Procedure Code Info
- ;Input:
- ;  CODE  ICD code or IEN format, (required)
- ;    CDT  Date (default = TODAY)
- ;    DFN  Not in use
- ;    SRC  Source
- ;           0 = exclude local codes
- ;           1 = include local codes
- ;
- ;Output:
- ;  Returns an 14 piece string delimited by ^
- ;    1  IEN of code in ^ICD9(
- ;    2  ICD-9 code (#.01)
- ;    3  Id (#2)
- ;    4  MDC24 (#5)
- ;    5  Versioned Oper/Proc (67 multiple)
- ;    6  <null>
- ;    7  <null>
- ;    8  <null>
- ;    9  ICD Expanded (#8) 1:Yes 0:No
- ;    10 Status (66 multiple)
- ;    11 Use with Sex (#9.5)
- ;    12 Inactive Date (66 multiple)
- ;    13 Activation Date (66 multiple)
- ;    14 Message
- ;
- ;    or
- ;
- ;    -1^Error Description
+ ; Input:   CODE  ICD code or IEN format, (required)
+ ;          CDT   Date (default = TODAY)
+ ;          DFN   Not in use
+ ;          SRC   Source
+ ;                0 = exclude local codes
+ ;                1 = include local codes
+ ;
+ ; Output:  Returns an 14 piece string delimited by ^
+ ;            1  IEN of code in ^ICD9(
+ ;            2  ICD-9 code (#.01)
+ ;            3  Id (#2)
+ ;            4  MDC24 (#5)
+ ;            5  Versioned Oper/Proc (67 multiple)
+ ;            6  <null>
+ ;            7  <null>
+ ;            8  <null>
+ ;            9  ICD Expanded (#8) 1:Yes 0:No
+ ;           10  Status (66 multiple)
+ ;           11  Use with Sex (#9.5)
+ ;           12  Inactive Date (66 multiple)
+ ;           13  Activation Date (66 multiple)
+ ;           14  Message
+ ;
+ ;           -or-
+ ;
+ ;          -1^Error Description
  ;
  N DATA,EFF,STR,INV
@@ -92,32 +85,30 @@
  I CODE<1 Q INV
  I '$D(^ICD0(CODE)) Q INV
- I '$G(SRC),$P(^ICD0(CODE,0),U,8) Q "-1^VA LOCAL CODE SELECTED"
+ I '$G(SRC),$P(^ICD0(CODE,0),"^",8) Q "-1^VA LOCAL CODE SELECTED"
  S DATA=$G(^ICD0(CODE,0)) I '$L(DATA) Q "-1^NO DATA"
  S CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT))
  S EFF=$$EFF^ICDSUPT(80.1,CODE,CDT)
- S $P(DATA,U,9)=$S(EFF<1:0,1:$P(EFF,U))
- S $P(DATA,U,11,12)=$P(EFF,U,2,3)
- S $P(DATA,U,4)=$$VSTP(CODE,CDT)
- Q CODE_U_DATA_U_$$MSG^ICDAPIU(CDT)
+ S $P(DATA,"^",9)=$S(EFF<1:0,1:$P(EFF,"^"))
+ S $P(DATA,"^",11,12)=$P(EFF,"^",2,3)
+ S $P(DATA,"^",4)=$$VSTP(CODE,CDT)
+ Q CODE_"^"_DATA_"^"_$$MSG^ICDAPIU(CDT)
  ;
 ICDD(CODE,OUTARR,CDT) ; returns ICD description in array
- ;Input:
- ;  CODE   ICD Code or IEN (required)
- ;    ARY    Array Name for description
- ;           e.g. "ABC" or "ABC("TEST")"
- ;           Default = ^TMP("ICDD",$J)
- ;    CDT    Date (default = TODAY)
- ;
- ;Output:
- ;  #   Number of lines in array
- ;
- ;  @ARY(1:n) - Versioned Description (68 multiple)
- ;  @ARY(n+1) - blank
- ;  @ARY(n+1) - message: CODE TEXT MAY BE INACCURATE
- ;
- ;  or
- ;
- ;  -1^Error Description
- ;
+ ; Input:   CODE   ICD Code or IEN (required)
+ ;          ARY    Array Name for description 
+ ;                 e.g. "ABC" or "ABC("TEST")" 
+ ;                 Default = ^TMP("ICDD",$J)
+ ;          CDT    Date (default = TODAY)
+ ; 
+ ; Output:  #      Number of lines in array
+ ; 
+ ;          @ARY(1:n) - Versioned Description (68 multiple)
+ ;          @ARY(n+1) - blank
+ ;          @ARY(n+1) - message: CODE TEXT MAY BE INACCURATE
+ ; 
+ ;           or
+ ; 
+ ;          -1^Error Description
+ ;          
  ; ** NOTE - USER MUST INITIALIZE ^TMP("ICDD",$J), IF USED **
  ;
@@ -137,4 +128,5 @@
  I OUTARR="^TMP(""ICDD"",$J," K ^TMP("ICDD",$J)
  S I=0,N=0,CDT=$S($G(CDT)="":$$DT^XLFDT,1:$$DTBR^ICDAPIU(CDT))
+ ;S N=N+1,ARR=OUTARR_N_")",@ARR=$G(@(GLOB_CODE_",1)"))
  S N=N+1,ARR=OUTARR_N_")",@ARR=$$VLT(CODE,CDT,GLOB)
  S N=N+1,ARR=OUTARR_N_")",@ARR=" "
@@ -143,17 +135,17 @@
  ;
 CODEN(CODE,FILE) ; return ien of ICD code
- ;Input:
- ;  CODE - ICD code (required)
- ;  FILE - File Number to search for code
- ;          80 = ICD Dx file
- ;          80.1 = ICD Oper/Proc file
- ;
- ;Output:
- ;  ien~global root
+ ;
+ ; Input:
+ ;    CODE - ICD code (required)
+ ;    FILE - File Number to search for code
+ ;           80 = ICD Dx file
+ ;           80.1 = ICD Oper/Proc file
+ ;
+ ; Output: ien~global root
  ;    where global root is:
- ;      "^ICD9(" - File 80
- ;      "^ICD0(" - File 80.1
- ;  or
- ;  -1~error message
+ ;           "^ICD9(" - File 80
+ ;           "^ICD0(" - File 80.1
+ ;    -or-
+ ;         -1~error message
  ;
  I $G(CODE)="" Q "-1~NO CODE SELECTED"
@@ -162,10 +154,10 @@
  ;use FILE if passed
  I $G(FILE) D  Q Y_"~"_GLOB
- .S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:INV_"FILE")
- .I $E(GLOB)'=U S Y=-1,GLOB=INV_"FILE" Q
- .S Y=$S(CODE?1.9N:$$CODEZ(CODE,GLOB),1:$$CODEBA(CODE,GLOB))
+ . S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:INV_"FILE")
+ . I $E(GLOB)'="^" S Y=-1,GLOB=INV_"FILE" Q
+ . S Y=$S(CODE?1.9N:$$CODEZ(CODE,GLOB),1:$$CODEBA(CODE,GLOB))
  ;FILE not passed - report where found
  I CODE?1.9N S GLOB="^ICD9(",Y=$$CODEZ(CODE,GLOB) D  G CODENQ
- .I Y<1 S GLOB="^ICD0(",Y=$$CODEZ(CODE,GLOB)
+ . I Y<1 S GLOB="^ICD0(",Y=$$CODEZ(CODE,GLOB)
  S GLOB=$S(CODE?2N1"."1.3N:"^ICD0(",CODE?3N1".".3N!(CODE?1U2.3N1".".2N):"^ICD9(",1:-1)
  S Y=$S('GLOB:$$CODEBA(CODE,GLOB),1:-1)
@@ -174,17 +166,17 @@
  ;
 CODEC(CODE,FILE) ;return the ICD code of an ien
- ;Input:
- ;  CODE - IEN of ICD code    REQUIRED
- ;  FILE - File Number to search for code
- ;         80 = ICD Dx file
- ;         80.1 = ICD Oper/Proc file
- ;
- ;Output: ICD code, -1 if not found
+ ;  Input:
+ ;    CODE - IEN of ICD code    REQUIRED
+ ;    FILE - File Number to search for code
+ ;           80 = ICD Dx file
+ ;           80.1 = ICD Oper/Proc file
+ ;
+ ; Output: ICD code, -1 if not found
  ;
  S CODE=$G(CODE) Q:CODE'?1.9N -1
  N Y,GLOB
  I $G(FILE) D  Q Y
- .S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:-1)
- .S Y=$S(GLOB<0:-1,1:$$CODEZ(CODE,GLOB))
+ . S GLOB=$S(FILE=80:"^ICD9(",FILE=80.1:"^ICD0(",1:-1)
+ . S Y=$S(GLOB<0:-1,1:$$CODEZ(CODE,GLOB))
  ;FILE not passed - Search for 1st match
  S Y=$$CODEZ(CODE,"^ICD9(",1)
@@ -193,22 +185,11 @@
 CODEZ(CODE,ROOT,FLG) ; Based on IEN/root:
  N Y,ICDL            ; if 'FLG return code existence, else zero node - piece 1
- S Y=$P($G(@(ROOT_CODE_",0)")),U),ICDL=$L(Y) I ICDL,'$G(FLG) Q CODE
+ S Y=$P($G(@(ROOT_CODE_",0)")),"^"),ICDL=$L(Y) I ICDL,'$G(FLG) Q CODE
  Q $S('ICDL:-1,1:Y)
+ ;
 CODEBA(CODE,ROOT) ; Return IEN based on code/root
  N IEN
  S IEN=$O(@(ROOT_"""BA"","""_CODE_" "","""")"),-1)
  Q $S('IEN:-1,1:IEN)
- ;
-COMCOM(IEN,VDT) ; Return versioned complication/comorbidity
- ;returns a code for complication/comorbidity
- ;  0 - non-CC
- ;  1 - CC
- ;  2 - MCC
- ;  -1 - versioned CC not on file for date
- N CCDATE,CCIEN
- S CCDATE=$O(^ICD9(IEN,69,"B",VDT+.0001),-1)
- I CCDATE="" Q -1
- S CCIEN=$O(^ICD9(IEN,69,"B",CCDATE,""),-1)
- Q $P(^ICD9(IEN,69,CCIEN,0),U,2)
  ;
 VST(IEN,VDT,TYPE)     ; Versioned Short Text
@@ -218,20 +199,20 @@
 VSTD(IEN,VDT)  ; Versioned Short Text (Dx)
  N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT S ICDI=+($G(IEN)) Q:+ICDI'>0 ""  Q:'$D(^ICD9(+ICDI)) ""
- S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""  S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
+ S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""  S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) ""
  S STD=$O(^ICD9("AST",(ICDC_" "),(ICDT+.000001)),-1)
  I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD9("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),U,2))
+ . S STI=$O(^ICD9("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),"^",2))
  S STD=$O(^ICD9(+ICDI,67,"B",0)) I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD9(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),U,2))
- Q $$TRIM($P(ICD0,U,3))
+ . S STI=$O(^ICD9(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD9(+ICDI,67,+STI,0)),"^",2))
+ Q $$TRIM($P(ICD0,"^",3))
 VSTP(IEN,VDT) ; Versioned Short Text (Proc)
  N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT S ICDI=+($G(IEN)) Q:+ICDI'>0 ""  Q:'$D(^ICD0(+ICDI)) ""
- S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""  S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
+ S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""  S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) ""
  S STD=$O(^ICD0("AST",(ICDC_" "),(ICDT+.000001)),-1)
  I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD0("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),U,2))
+ . S STI=$O(^ICD0("AST",(ICDC_" "),STD,+ICDI," "),-1),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),"^",2))
  S STD=$O(^ICD0(+ICDI,67,"B",0)) I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD0(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),U,2))
- Q $$TRIM($P(ICD0,U,4))
+ . S STI=$O(^ICD0(+ICDI,67,"B",STD,0)),TXT=$$TRIM($P($G(^ICD0(+ICDI,67,+STI,0)),"^",2))
+ Q $$TRIM($P(ICD0,"^",4))
 VLT(IEN,VDT,TYPE) ; Version Description - Long Text
  Q:TYPE["ICD9(" $$VLTD($G(IEN),$G(VDT))
@@ -242,30 +223,30 @@
  S ICDI=+($G(IEN)) Q:+ICDI'>0 ""  Q:'$D(^ICD9(+ICDI)) ""
  S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""
- S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
+ S ICD0=$G(^ICD9(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) ""
  S STD=$O(^ICD9("ADS",(ICDC_" "),(ICDT+.000001)),-1)
  I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD9("ADS",(ICDC_" "),STD,+ICDI," "),-1)
- .S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),U,1))
+ . S STI=$O(^ICD9("ADS",(ICDC_" "),STD,+ICDI," "),-1)
+ . S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),"^",1))
  S STD=$O(^ICD9(+ICDI,68,"B",0))
  I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD9(+ICDI,68,"B",STD,0))
- .S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),U,1))
+ . S STI=$O(^ICD9(+ICDI,68,"B",STD,0))
+ . S TXT=$$TRIM($P($G(^ICD9(+ICDI,68,+STI,1)),"^",1))
  S TXT=$$TRIM($G(^ICD9(+ICDI,1))) Q:$L($G(TXT)) $G(TXT)
- Q $$TRIM($P(ICD0,U,3))
+ Q $$TRIM($P(ICD0,"^",3))
 VLTP(IEN,VDT) ; Versioned Description - Long Text (Proc)
  N ICD0,ICDC,ICDI,STD,STI,ICDT,TXT
  S ICDI=+($G(IEN)) Q:+ICDI'>0 ""  Q:'$D(^ICD0(+ICDI)) ""
  S ICDT=$G(VDT) S:'$L(ICDT)!(+ICDT'>0) ICDT=$$DT^XLFDT Q:$P(ICDT,".",1)'?7N ""
- S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,U,1) Q:'$L(ICDC) ""
+ S ICD0=$G(^ICD0(+ICDI,0)),ICDC=$P(ICD0,"^",1) Q:'$L(ICDC) ""
  S STD=$O(^ICD0("ADS",(ICDC_" "),(ICDT+.000001)),-1)
  I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD0("ADS",(ICDC_" "),STD,+ICDI," "),-1)
- .S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),U,1))
+ . S STI=$O(^ICD0("ADS",(ICDC_" "),STD,+ICDI," "),-1)
+ . S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),"^",1))
  S STD=$O(^ICD0(+ICDI,68,"B",0))
  I +STD>0 D  Q:$L($G(TXT)) $G(TXT)
- .S STI=$O(^ICD0(+ICDI,68,"B",STD,0))
- .S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),U,1))
+ . S STI=$O(^ICD0(+ICDI,68,"B",STD,0))
+ . S TXT=$$TRIM($P($G(^ICD0(+ICDI,68,+STI,1)),"^",1))
  S TXT=$$TRIM($G(^ICD0(+ICDI,1))) Q:$L($G(TXT)) $G(TXT)
- Q $$TRIM($P(ICD0,U,4))
+ Q $$TRIM($P(ICD0,"^",4))
 TRIM(X) ; Trim Spaces
  S X=$G(X) Q:X="" X F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG.m	(revision 636)
@@ -1,4 +1,4 @@
-ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 11/13/07 4:07pm
- ;;18.0;DRG Grouper;**2,7,10,14,20,31**;Oct 20, 2000;Build 7
+ICDDRG ;ALB/GRR/EG/ADL - ASSIGNS DRG CODES ; 5/19/05 12:52pm
+ ;;18.0;DRG Grouper;**2,7,10,14,20**;Oct 20, 2000;Build 1
  ;ADL - UPDATED FOR CSV;3/10/03
 TOP S (ICDDRG,ICDMDC,ICDRTC)=""
@@ -19,5 +19,5 @@
  I ICDTMP<0 S ICDRTC=1 G ERR
  S ICDY(0)=$P(ICDTMP,U,2,99) I $P(ICDY(0),"^",4)=1!($P(ICDY(0),"^",9)=0) S ICDRTC=1 G ERR  ;flag has changed from inactive flag to status flag
- S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0 I 'ICDMDC S ICDRTC=1 G ERR
+ S ICDMDC=$P(ICDY(0),"^",5),ICDPD=$P(ICDY(0),"^",2),ICDRG=0 I 'ICDMDC S ICDDRG=469,ICDRTC=1 G ERR
  D MDCG
  I $D(ICDMDC(12))!($D(ICDMDC(13))) S ICDMDC=$S(SEX="F":13,1:12) I SEX="" S ICDRTC=4 G ERR
@@ -30,5 +30,5 @@
  ;FOLLOWING ESTABLISHES SECONDARY DIAGNOSIS VARIABLES
  ;
- S (ICDCCT,ICDMCCT,ICDSD)="",ICDCC=0,ICDMCC=0,ICDI=1
+ S (ICDCCT,ICDSD)="",ICDCC=0,ICDI=1
  F ICDIZ=0:0 S ICDI=$O(ICDDX(ICDI)) Q:ICDI'>0  D  G:ICDRTC]"" ERR
  . S ICDTMP=$$ICDDX^ICDCODE(ICDDX(ICDI),ICDDATE) I ICDTMP<0!'($P(ICDTMP,U,10)) S ICDRTC=8 Q
@@ -37,5 +37,4 @@
  . D SEC,SEX9 G:ICDRTC]"" ERR
  S:$D(ICDCCT(1)) ICDCC=1 K ICDCCT
- S:$D(ICDMCCT(1)) ICDMCC=1 S:$D(ICDMCCT(2)) ICDMCC=2 K ICDMCCT
  ;********************************************************
  ;FOLLOWING ESTABLISHES OPERATION/PROCEDURE VARIABLES
@@ -47,8 +46,5 @@
  K ICDO24("N") G:ICDRTC]"" ERR
  G ^ICDDRG0
-SEC I ICDDATE>3070930.9 D
- .S ICDMCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",18)=2:2,($P(ICDY(0),"^",18)=1)&(ICDMCC'=2):1,1:ICDMCC),ICDMCCT(ICDMCC)=""
- E  D
- .S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)=""
+SEC S ICDCC=$S($D(^ICD9("ACC",ICDDX(ICDI),ICDDX(1))):0,$P(ICDY(0),"^",7)=1:1,1:ICDCC),ICDCCT(ICDCC)=""
  ;Group ICD identifiers in one variable
  S ICDSD=ICDSD_$P(ICDY(0),"^",2)
@@ -79,5 +75,5 @@
  ;translate specific identifiers into common symbol, check for symbol
  S ICD104=$S($P(ICDY(0),"^",2)["P":1,1:0),ICDNMDC($S($TR($P(ICDY(0),"^",2),"lqtrB","\\\\")["\":1,1:0))="" Q
-ERR S ICDDRG=$S(ICDDATE>3070930.9:999,1:470)
+ERR S ICDDRG=470
  Q  ;ERR
 SEX9 ;get sex for dx or proc
@@ -105,5 +101,5 @@
  Q 1
 KILL K ICD104,ICDJ,ICDJJ,ICDOCNT,ICDOR,ICDNOR,ICDP15,ICDPDRG,ICDRG,ICDSEX
- K ICDSDRG,ICDODRG,ICDCC,ICDMCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
+ K ICDSDRG,ICDODRG,ICDCC,ICDOP,ICDORNR,ICDORNI,ICDP24,ICDP25,ICDPD
  K ICDSD,ICDI,ICDK,ICDF,ICDFX,ICDFK,ICDY,ICDDXT,ICDIZ,ICDONR,ICDOPCT
  K ICD,ICDCC2,ICDCC3,ICDGH,ICDL39,ICDMAJ,ICDNMDC,ICDNSD,ICDORNA,ICDREF,ICDS25
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG0.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG0.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG0.m	(revision 636)
@@ -1,51 +1,42 @@
-ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 11/13/07 4:06pm
- ;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30,31,32**;Oct 20, 2000;Build 9
+ICDDRG0 ;ALB/GRR/EG/ADL - DRG GROUPER PROCESSING BEGINS ; 5/16/05 9:05pm
+ ;;18.0;DRG Grouper;**1,2,7,10,14,17,20,24,27,30**;Oct 20, 2000;Build 5
  ;GROUPING PROCESS BEGINS
  ;
 GROUP ;
- I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDDRG=$S(ICDDATE>3070930.9:999,1:470) G KILL^ICDDRG
- I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15 D:ICDOPCT<2  I ((ICDDATE'>3070930.9)&("468^476^477"[ICDRG))!((ICDDATE>3070930.9)&("983^986^989"[ICDRG)) G END
+ I $D(ICDSEX(1))&($D(ICDSEX(2))) S ICDRTC=4,ICDDRG=470 G KILL^ICDDRG
+ I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15 D:ICDOPCT<2  I "468^476^477"[ICDRG G END
+ . ;I ICDPD["M",ICDOR'["a" S ICDPDRG(344)="",ICDOPCT=0
  . I $D(ICDF) Q
  . I ICDPD["M",ICDOR'["y" S ICDOPCT=0 Q
- . I ICDDATE>3070930.9 D
- . . I ICDORNI["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(769)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):983,ICDORNI["y":986,ICDORNI["z":989,1:983) Q
- . . I ICDOPNR S ICDRG=$S(ICDORNI["y":986,1:983),ICDOPNR=0 Q
- . E  D
- . . I ICDORNI["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(377)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):468,ICDORNI["y":476,ICDORNI["z":477,1:468) Q
- . . I ICDOPNR S ICDRG=$S(ICDORNI["y":476,1:468),ICDOPNR=0 Q
+ .I ICDORNI["O",ICDNOR=ICDONR,ICDNOR>0,'$D(ICDPDRG(377)),ICDORNI'["p" S ICDRG=$S($D(ICDORNI("O")):468,ICDORNI["y":476,ICDORNI["z":477,1:468) Q
+ .I ICDOPNR S ICDRG=$S(ICDORNI["y":476,1:468),ICDOPNR=0 Q
  ;
  ;if number of non-extensive ORs eqs # OR, 477
  ;
- I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z") D  I ((ICDDATE'>3070930.9)&(ICDRG=477))!((ICDDATE>3070930.9)&(ICDRG=989)) G END
+ I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI'["y"&(ICDORNI'="")&(ICDORNI["z") D  I ICDRG=477 G END
  . I $D(ICDF) Q
- . NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG=$S(ICDDATE>3070930.9:989,1:477) Q
+ . NEW K S K=$$ORNI(ICDORNI) I K=ICDOPCT S ICDRG=477 Q
  ;
  ;if number of non-extensive ORs+prostatics eqs # OR, 476
  ;
- I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI["y"&(ICDORNI'="") D  I ((ICDDATE'>3070930.9)&(ICDRG=476))!((ICDDATE>3070930.9)&(ICDRG=986)) G END
- .N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG=$S(ICDDATE>3070930.9:986,1:476) Q
- I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG=$S(ICDDATE>3070930.9:983,1:468) G END
- I ICDMDC=5,ICDOR'["O" S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG=$S(ICDDATE>3070930.9:999,1:470) D:ICDRTC="" MI G END
+ I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDORNI["y"&(ICDORNI'="") D  I ICDRG=476 G END
+ .N K S K=$$ORNI(ICDORNI) I K=ICDOPCT&(ICDNOR=ICDONR) S ICDRG=476 Q
+ I ICDMDC'=14,ICDMDC'=17,ICDMDC'=18,ICDMDC'=19,ICDMDC'=20,ICDMDC'=23,ICDMDC'=15,ICDNOR=ICDONR&(ICDOPCT>0) S ICDRG=468 G END
+ I ICDMDC=5,ICDOR'["O" S ICDRTC=$S(ICDEXP="":5,1:"") S:ICDRTC'="" ICDRG=470 D:ICDRTC="" MI G END
  ;I ICDMDC=18,ICDOR["O"!(ICDORNI["O") S ICDRG=415 G END  ;;disabled by ICD*18*24 and new DRGs 578/579 - see ICDTLB6C
- I ICDMDC=19,ICDOCNT>0,ICDOR["O" S (ICDRG,HICDRG)=$S(ICDDATE>3070930.9:876,1:424) D CKDRG
- I ICDMDC=23,ICDOR["O"!(ICDORNI["O") S ICDRG=$S(ICDDATE>3070930.9:941,1:461) G END
+ I ICDMDC=19,ICDOCNT>0,ICDOR["O" S (ICDRG,HICDRG)=424 D CKDRG
+ I ICDMDC=23,ICDOR["O"!(ICDORNI["O") S ICDRG=461 G END
  I ICDMDC=14 D ^ICDDRG14 I ICDRG]"" G END
- I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 D  G END
- . I ICDDATE>3070930.9 S ICDRG=$S(ICDDMS="":999,1:894) Q
- . S ICDRG=$S(ICDDMS="":470,1:433)
- I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=$S(ICDDATE>3070930.9:999,1:470) D:ICDRTC="" CKBURN G END
- I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 D  G END
- . I ICDDATE>3070930.9 S ICDRG=$S(ICDRTC'="":999,1:789) Q
- . S ICDRG=$S(ICDRTC'="":470,1:385)
-NEONATE I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG D NEONATF^ICDDRG0" D  D DODRG G GETMOR:ICDRG="",END
+ I ICDMDC=20 S ICDRTC=$S(ICDDMS="":7,1:"") I ICDDMS'=0 S ICDRG=$S(ICDDMS="":470,1:433) G END
+ I ICDMDC=22 S ICDRTC=$S(ICDTRS="":6,1:"") S:ICDRTC'="" ICDRG=470 D:ICDRTC="" CKBURN G END
+ I ICDMDC=15 S ICDRTC=$S(ICDEXP="":5,ICDTRS="":6,1:"") I ICDTRS'=0 S ICDRG=$S(ICDRTC'="":470,1:385) G END
+NEONATE I 'ICDNOR!('$D(ICDODRG)) S ICDRG=$O(ICDPDRG(0)) X "I ICDMDC=15,$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))" D  D DODRG G GETMOR:ICDRG="",END
  . N X,X1,X2,%
  . S X1=$S($G(DGADM):$G(DGADM),1:DT),X2=$G(DOB) I X1,X2 D ^%DTC I X<29 D NBCOMP Q
- . I ICDDATE'>3070930.9 I ICDRG<385!(ICDRG>391) Q
- . I ICDDATE>3070930.9 I ICDRG<789!(ICDRG>795) Q
+ . I ICDRG<385!(ICDRG>391) Q
  .; I "^11917^11918^11921^"[("^"_ICDDX(1)_"^") S ICDRG=395 Q
- . I ICDDATE'>3070930.9 I $O(ICDRG(391)) S ICDRG=$O(ICDRG(391)) Q
- . I ICDDATE>3070930.9 I $O(ICDRG(795)) S ICDRG=$O(ICDRG(795)) Q
- . I 'ICDRG S ICDRG=$S(ICDDATE>3070930.9:999,1:470),ICDRTC=8
- I AGE="",ICDMDC=3 S ICDRTC=3 S ICDRG=$S(ICDDATE>3070930.9:999,1:470) G END
+ . I $O(ICDRG(391)) S ICDRG=$O(ICDRG(391)) Q
+ . I 'ICDRG S ICDRG=470,ICDRTC=8
+ I AGE="",ICDMDC=3 S ICDRTC=3,ICDRG=470 G END
  D ^ICDDRG1:ICDMDC=1,^ICDDRG2:ICDMDC=2,^ICDDRG3:ICDMDC=3,^ICDDRG5:ICDMDC=5,^ICDDRG6:ICDMDC=6,^ICDDRG7:ICDMDC=7,^ICDDRG8:ICDMDC=8,^ICDDRG9:ICDMDC=9,^ICDDRG10:ICDMDC=10,^ICDDRG11:ICDMDC=11,^ICDDRG12:ICDMDC=12,^ICDDRG13:ICDMDC=13
  D ^ICDDRG17:ICDMDC=17
@@ -53,6 +44,6 @@
  D DODRG
  G:ICDRG'>0 LOOK8:ICDMDC=8,AGAIN G END
-ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG=$S(ICDDATE>3070930.9:983,1:468) G END
-GETMOR S (ICDRG,HICDRG)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,HICDRG)=$S(ICDDATE>3070930.9:998,1:469)
+ENTER I 'ICDNOR,ICDORNR'=0,ICDMDC'=20,ICDMDC'=15 S ICDRG=468 G END
+GETMOR S (ICDRG,HICDRG)=$O(ICDPDRG(0)) S:ICDRG'>0 (ICDRG,HICDRG)=469 ;I ICDMDC=15,'$D(ICDODRG),$D(ICDSDRG),$O(ICDSDRG(0))<ICDRG S (ICDRG,HICDRG)=$O(ICDSDRG(0))
 CKDRG D DODRG
  I ICDRG="" K ICDPDRG(HICDRG) G GETMOR
@@ -61,5 +52,5 @@
  N DRGFY,ICDREF S (DRGFY,ICDREF)=""
  I ICDRG S DRGFY=$O(^ICD(ICDRG,2,"B",$P(+$G(ICDDATE),".")_.01),-1)
- I 'DRGFY S DRGFY=3071001 ;default to current fiscal year
+ I 'DRGFY S DRGFY=3061001 ;default to current fiscal year
  S ICDREF=$O(^ICD(+ICDRG,2,"B",+DRGFY,ICDREF))
  I ICDREF'="" D
@@ -75,64 +66,44 @@
  D:ICDP24'=""!($D(ICDS24)) CKMST^ICDDRGX S ICDDRG=ICDRG
  ;ICD*18*24 check for higher numbered DRG (such as new DRG 561) before checking for 489 in CKHIV^ICDDRGX
- I ICDDATE<3071001 I ICDRG=489!(ICDRG=490)!(ICDRG=543&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=543 S ICDRG=561
- I ICDDATE'<3071001 I ICDRG=976!(ICDRG=977)!(ICDRG=24&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=24 S ICDRG=99
+ I ICDRG=489!(ICDRG=490)!(ICDRG=543&($G(ICDOR)="")) S ICDRG=$P($G(ICDPDRG),U,2) I ICDRG=543 S ICDRG=561
  D:$G(ICDP25)=1!(($G(ICDP25)>1)&($D(ICDS25(1)))) CKHIV^ICDDRGX S ICDDRG=ICDRG
  ; this will effectively make DRG 103 into a pre-MDC (ICD*18*1)
- I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($D(ICDOP(" 37.51"))!$D(ICDOP(" 37.66")))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG
- I (ICDDATE>3050930.9)&($D(ICDOP(" 37.64")))&($D(ICDOP(" 37.65"))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG
- I (ICDDATE>3060930.9)&($D(ICDOP(" 37.63")))&($D(ICDOP(" 37.64"))) S ICDRG=$S(ICDDATE>3070930.9:2,1:103),ICDNMDC(1)="" D DODRG
- I $D(ICDOP(" 39.65")) S ICDRG=$S(ICDDATE>3070930.9:3,1:541),ICDNMDC(1)=""
- I (ICDDATE>3070930.9)&($D(ICDOP(" 46.97"))) S ICDRG=5,ICDNMDC(1)=""
+ I $D(ICDOP(" 33.6"))!$D(ICDOP(" 37.5"))!(ICDDATE>3030930.9&($D(ICDOP(" 37.51"))!$D(ICDOP(" 37.66")))) S ICDRG=103,ICDNMDC(1)=""
+ I (ICDDATE>3050930.9)&($D(ICDOP(" 37.64")))&($D(ICDOP(" 37.65"))) S ICDRG=103,ICDNMDC(1)=""
+ I (ICDDATE>3060930.9)&($D(ICDOP(" 37.63")))&($D(ICDOP(" 37.64"))) S ICDRG=103,ICDNMDC(1)=""
+ I $D(ICDOP(" 39.65")) S ICDRG=541,ICDNMDC(1)=""
  ; this will create DRGs 512/513 as pre-MDC
- I $D(ICDOP(" 52.80"))!$D(ICDOP(" 52.82")) S ICDRG=$S(ICDDATE>3070930.9:10,1:513),ICDNMDC(1)=""
- I (ICDDATE>3070930.9) D
- . I ICDRG=10 I $D(ICDOP(" 55.69")) S ICDRG=8
- E  I ICDRG=513 I $D(ICDOP(" 55.69")) S ICDRG=512
+ I $D(ICDOP(" 52.80"))!$D(ICDOP(" 52.82")) S ICDRG=513,ICDNMDC(1)=""
+ I ICDRG=513 I $D(ICDOP(" 55.69")) S ICDRG=512
  ; this will create DRG 481 as pre-MDC - loops thru 41.00 thru .09
- N X S X=0 F  S X=$O(ICDOP(X)) Q:X=""  I X["41.0" S ICDRG=$S(ICDDATE>3070930.9:9,1:481),ICDNMDC(1)=""
+ N X S X=0 F  S X=$O(ICDOP(X)) Q:X=""  I X["41.0" S ICDRG=481,ICDNMDC(1)=""
  I $D(ICDNMDC(1)) I ICDNMDC(1)="" D CKNMDC^ICDDRGX S ICDDRG=ICDRG K ICDNMDC
- I ICDDATE>3070930.9 D
- . I ICDRG=983 D CHKMDC4^ICDDRGX
- . D DODRG S ICDDRG=ICDRG ;check for MCC/CC
- E  I ICDRG=468 D CHKMDC4^ICDDRGX D DODRG S ICDDRG=ICDRG
+ I ICDRG=468 D CHKMDC4^ICDDRGX D DODRG S ICDDRG=ICDRG
  S:ICDRTC="" ICDRTC=0
- S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDDRG=$S(ICDDATE>3070930.9:999,1:470)
+ S ICDTMP=$$DRG^ICDGTDRG(ICDDRG,ICDDATE) I '$P(ICDTMP,U,14) S ICDDRG=470
  G KILL^ICDDRG
 MI ;
  ; if PTCA and not a bypass
- I ICDOR["1"!($D(ICDOP(" 37.90"))) I ICDOR'["b"&(ICDOR'["6") D  Q
- . I ICDDATE>3070930.9 D CMS516^ICDTBL2 Q
- . E  D DRG516^ICDTLB6B
+ I ICDOR["1"!($D(ICDOP(" 37.90"))) I ICDOR'["b"&(ICDOR'["6") I ICDDATE>3050930.9 D DRG516^ICDTLB6B Q
  I ICDPD["A" D EN1^ICDDRG5 I ICDCC3 S ICDRG=$O(ICDODRG(0)) D DODRG Q
  I ICDPD["AI"!(ICDSD["AI") D  Q
- . I ICDDATE>3070930.9 D
- . . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):285,ICDPD["V"!(ICDSD["V"):280,1:282)
- . E  D 
- . . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=526 Q
- . . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["V"!(ICDSD["V"):121,1:122)
- I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=$S(ICDDATE>3070930.9:230,1:108) Q
+ . I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=526 Q
+ . S ICDRG=$S($S($D(ICDEXP):ICDEXP,1:0):123,ICDPD["V"!(ICDSD["V"):121,1:122)
+ I $D(ICDOP(" 37.26"))&($D(ICDOP(" 39.61"))) S ICDRG=108 Q
  ;I $D(ICDOP(" 37.26")) S ICDRG=112 Q
- I ICDDATE<3071001 I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=527 Q
- I ICDDATE<3071001 I $D(ICDOP(" 36.06")) I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=517 Q
- I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=$S(ICDDATE>3070930.9:251,1:518) Q
- I ICDOR["H" D  Q
- . I ICDDATE>3070930.9  S ICDRG=$S(ICDPD["X"!(ICDSD["X"):286,1:287) Q
- . E  S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
- I ICDDATE>3070930.9 K ICDPDRG(286),ICDPDRG(287)
- E  K ICDPDRG(124)
+ I $D(ICDOP(" 36.07")) I $D(ICDOP(" 37.26"))!($D(ICDOP(" 37.27"))) S ICDRG=527 Q
+ I $D(ICDOP(" 36.06")) I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=517 Q
+ I $D(ICDOP(" 37.26"))!$D(ICDOP(" 37.27")) S ICDRG=518 Q 
+ I ICDOR["H" S ICDRG=$S(ICDPD["X"!(ICDSD["X"):124,1:125) Q
+ K ICDPDRG(124)
  I ICDOR["p" S ICDRG=$O(ICDODRG(0)) D DODRG Q
  I ICDOR["F" S ICDRG=$O(ICDODRG(0)) D DODRG Q
- E  D  Q
- . I ICDDATE>3070930.9 K ICDPDRG(280),ICDPDRG(281),ICDPDRG(282) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
- . E  K ICDPDRG(121) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
+ E  K ICDPDRG(121) S ICDRG=$O(ICDPDRG(0)) D DODRG Q
  ;
 CKBURN ; MDC22 - Burns (extensive, full thickness, or non-extensive)
  D
- . I ICDPD["*"!(ICDSD["*") D  Q
- . . I ICDDATE>3070930.9 S ICDRG=$S(ICDOR["k":927,1:933) Q
- . . E  S ICDRG=$S(ICDOR["k":504,1:505) Q
+ . I ICDPD["*"!(ICDSD["*") S ICDRG=$S(ICDOR["k":504,1:505) Q
  . I ICDPD["b"!(ICDSD["b") D FTBURN Q
- . I ICDDATE>3070930.9 S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):935,1:935)
- . E  S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511)
+ . S ICDRG=$S(ICDCC!(ICDPD["T")!(ICDSD["T"):510,1:511)
  Q
  ;
@@ -151,23 +122,14 @@
  N ICDSDXCK
  S ICDSDXCK=$O(ICDSDRG(0))
- I ICDDATE>3070930.9 D
- . I ICDSDXCK<ICDRG,ICDSDXCK>788,ICDSDXCK<796 D
- .. S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0)))
- E  D
- . I ICDSDXCK<ICDRG,ICDSDXCK>384,ICDSDXCK<392 D
- .. S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))
+ I ICDSDXCK<ICDRG,ICDSDXCK>384,ICDSDXCK<392 D
+ . S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))
  Q
  ;
 FTBURN ; full thickness burn check
  I ICDSD["j"!(ICDOR["k") D
- . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=$S(ICDDATE>3070930.9:928,1:506)
- . E  S ICDRG=$S(ICDDATE>3070930.9:929,1:507)
+ . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=506
+ . E  S ICDRG=507
  E  D
- . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=$S(ICDDATE>3070930.9:934,1:508)
- . E  S ICDRG=$S(ICDDATE>3070930.9:934,1:509)
+ . I ICDCC!(ICDPD["T")!(ICDSD["T") S ICDRG=508
+ . E  S ICDRG=509
  Q
- ;
-NEONATF ;NEONATE - Continuation of xecute line
- I ICDDATE>3070930.9 S ICDRG=$S($D(ICDPDRG(795)):795,$D(ICDPDRG(791)):791,1:$O(ICDSDRG(0))) Q
- S ICDRG=$S($D(ICDPDRG(391)):391,$D(ICDPDRG(387)):387,1:$O(ICDSDRG(0)))
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG1.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG1.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG1.m	(revision 636)
@@ -1,8 +1,7 @@
-ICDDRG1 ;ALB/MRY - FIX SURGERY HIERARCHY ; 11/14/07 5:30pm
- ;;18.0;DRG Grouper;**10,17,24,31**;Oct 20, 2000;Build 7
+ICDDRG1 ;ALB/MRY - FIX SURGERY HIERARCHY ; 6/15/05 7:07pm
+ ;;18.0;DRG Grouper;**10,17,24**;Oct 20, 2000;Build 5
  Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D
- . I ICDDATE<3061001 D F Q
- . E  I ICDDATE<3071001 D FY2007 Q
- . E  D FY2008
+ .I ICDDATE<3061001 D F
+ .E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q
 F I ICDJ=3 S ICDJ(1)=ICDJ Q
@@ -86,13 +85,2 @@
  I ICDJ=35 S ICDJ(39)=ICDJ Q
  Q
-FY2008 ;MS-DRG
- I ICDJ=27 S ICDJ(1)=ICDJ Q
- I ICDJ=22 S ICDJ(2)=ICDJ Q
- I ICDJ=24 S ICDJ(3)=ICDJ Q
- ;I ICDJ=27 S ICDJ(3)=ICDJ Q
- I ICDJ=30 S ICDJ(4)=ICDJ Q
- I ICDJ=33 S ICDJ(5)=ICDJ Q
- I ICDJ=36 S ICDJ(6)=ICDJ Q
- I ICDJ=39 S ICDJ(7)=ICDJ Q
- I ICDJ=42 S ICDJ(8)=ICDJ Q
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG10.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG10.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG10.m	(revision 636)
@@ -1,8 +1,7 @@
 ICDDRG10 ;ALB/GRR - FIX SURGERY HIERARCHY ; 11/6/00 2:03pm
- ;;18.0;DRG Grouper;**24,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5
  Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- . I ICDDATE<3061001 D F Q
- . E  I ICDDATE<3071001 D FY2007 Q
- . E  D FY2008
+ . I ICDDATE<3061001 D F
+ . E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=286 S ICDJ(1)=ICDJ Q
@@ -15,10 +14,2 @@
  I ICDJ=288 S ICDJ(3)=ICDJ
  Q
-FY2008 ;MS-DRG
- I ICDJ=615 S ICDJ(1)=ICDJ Q
- I ICDJ=618 S ICDJ(2)=ICDJ Q
- I ICDJ=621 S ICDJ(3)=ICDJ Q
- I ICDJ=624 S ICDJ(4)=ICDJ Q
- I ICDJ=627 S ICDJ(5)=ICDJ Q
- I ICDJ=630 S ICDJ(6)=ICDJ
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG11.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG11.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG11.m	(revision 636)
@@ -1,7 +1,5 @@
 ICDDRG11 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:42am
- ;;18.0;DRG Grouper;**24,31**;Oct 20, 2000;Build 7
- Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- . I ICDDATE<3071001 D F Q
- . E  D FY2008
+ ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5
+ Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D F
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=302 S ICDJ(1)=ICDJ Q
@@ -9,12 +7,2 @@
  I ICDJ=303 S ICDJ(3)=ICDJ Q
  Q
-FY2008 ;MS-DRG
- I ICDJ=652 S ICDJ(1)=ICDJ Q
- I ICDJ=655 S ICDJ(2)=ICDJ Q
- I ICDJ=658 S ICDJ(3)=ICDJ Q
- I ICDJ=661 S ICDJ(4)=ICDJ Q
- I ICDJ=667 S ICDJ(5)=ICDJ Q
- I ICDJ=670 S ICDJ(6)=ICDJ Q
- I ICDJ=672 S ICDJ(7)=ICDJ Q
- I ICDJ=675 S ICDJ(8)=ICDJ
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG12.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG12.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG12.m	(revision 636)
@@ -1,7 +1,5 @@
 ICDDRG12 ;ALB/GRR - FIX SURGERY HIERARCHY ; 10/23/00 11:37am
- ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
- Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- . I ICDDATE<3071001 D F Q
- . E  D FY2008
+ ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
+ Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D F
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=334 S ICDJ(1)=ICDJ Q
@@ -13,9 +11,2 @@
  I ICDJ=344 S ICDJ(7)=ICDJ
  Q
-FY2008 ;MS-DRG
- I ICDJ=708 S ICDJ(1)=ICDJ Q
- I ICDJ=710 S ICDJ(2)=ICDJ Q
- I ICDJ=712 S ICDJ(3)=ICDJ Q
- I ICDJ=714 S ICDJ(4)=ICDJ Q
- I ICDJ=718 S ICDJ(5)=ICDJ Q
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG13.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG13.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG13.m	(revision 636)
@@ -1,8 +1,7 @@
 ICDDRG13 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:38am
- ;;18.0;DRG Grouper;**24,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5
  Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- . I ICDDATE<3061001 D F Q
- . E  I ICDDATE<3071001 D FY2007 Q
- . E  D FY2008
+ . I ICDDATE<3061001 D F
+ . E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=353 S ICDJ(1)=ICDJ Q
@@ -35,12 +34,2 @@
  I ICDJ=365 S ICDJ(13)=ICDJ
  Q
-FY2008 ;
- I ICDJ=735 S ICDJ(1)=ICDJ Q
- I ICDJ=738 S ICDJ(2)=ICDJ Q
- I ICDJ=741 S ICDJ(3)=ICDJ Q
- I ICDJ=743 S ICDJ(4)=ICDJ Q
- I ICDJ=745 S ICDJ(5)=ICDJ Q
- I ICDJ=747 S ICDJ(6)=ICDJ Q
- I ICDJ=748 S ICDJ(7)=ICDJ Q
- I ICDJ=750 S ICDJ(8)=ICDJ
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG14.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG14.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG14.m	(revision 636)
@@ -1,14 +1,9 @@
 ICDDRG14 ;ALB/GRR - FIX SURGERY HIERARCHY ; 9/29/04 3:48pm
- ;;18.0;DRG Grouper;**14,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1
  ;
- G POST:ICDPD'["D" I ICDOR["c" D  Q
- . I ICDDATE>3070930.9 S ICDRG=766
- . E  S ICDRG=$S(ICDCC:370,1:371)
-NOV I ICDOR["s"!(ICDOR["g") D  Q
- . I ICDDATE>3070930.9 S ICDRG=$S(ICDOR["s":767,1:768)
- . E  S ICDRG=$S(ICDOR["s":374,1:375)
+ G POST:ICDPD'["D" I ICDOR["c" S ICDRG=$S(ICDCC:370,1:371) Q
+NOV I ICDOR["s"!(ICDOR["g") S ICDRG=$S(ICDOR["s":374,1:375) Q
  ;
- I ICDDATE>3070930.9 S ICDRG=$S(ICDSD["n"!(ICDPD["n"):774,1:775) Q
- E  S ICDRG=$S(ICDSD["n"!(ICDPD["n"):372,1:373) Q
+ S ICDRG=$S(ICDSD["n"!(ICDPD["n"):372,1:373) Q
  ;
 POST N DRGFY,ICDREF
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG17.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG17.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG17.m	(revision 636)
@@ -1,7 +1,5 @@
 ICDDRG17 ;ALB/EG - FIX SURGERY HIERARCHY ; 10/9/03 11:41am
- ;;18.0;DRG Grouper;**10,31**;Oct 20, 2000;Build 7
- Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D
- . I ICDDATE<3071001 D F Q
- . E  D FY2008
+ ;;18.0;DRG Grouper;**10**;Oct 20, 2000;Build 1
+ Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D F
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q
 F I ICDJ=539 S ICDJ(1)=ICDJ Q
@@ -24,8 +22,2 @@
  I ICDJ=414 S ICDJ(18)=ICDJ Q
  Q
-FY2008 ;
- I ICDJ=822 S ICDJ(1)=ICDJ Q
- I ICDJ=825 S ICDJ(2)=ICDJ Q
- I ICDJ=828 S ICDJ(3)=ICDJ Q
- I ICDJ=830 S ICDJ(4)=ICDJ
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG2.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG2.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG2.m	(revision 636)
@@ -1,8 +1,7 @@
 ICDDRG2 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:39am
- ;;18.0;DRG Grouper;**24,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5
  Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D
- .I ICDDATE<3061001 D F Q
- .E  I ICDDATE<3071001 D FY2007 Q
- .E  D FY2008
+ .I ICDDATE<3061001 D F
+ .E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q
 F I ICDJ=37 S ICDJ(1)=ICDJ Q
@@ -21,9 +20,4 @@
  I ICDJ=38 S ICDJ(6)=ICDJ Q
  Q
-FY2008 ;
- I ICDJ=114 S ICDJ(1)=ICDJ Q
- I ICDJ=115 S ICDJ(2)=ICDJ Q
- I ICDJ=117 S ICDJ(3)=ICDJ Q
- Q
 VER S ICDF="",ICDL39=0 F ICDFZ=1:1 S ICDF=$O(ICDOP(ICDF)) Q:ICDF=""  S ICD=$P(ICDF," ",2) I "12.91^12.92^14.71^14.72^14.73^14.74^14.75^14.79"'[ICD S ICDL39=1 Q
  S ICDRG=$S(ICDL39:39,1:42)
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG3.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG3.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG3.m	(revision 636)
@@ -1,8 +1,7 @@
 ICDDRG3 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:39am
- ;;18.0;DRG Grouper;**24,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**24**;Oct 20, 2000;Build 5
  Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D
- .I ICDDATE<3061001 D F Q
- .E  I ICDDATE<3071001 D FY2007 Q
- .E  D FY2008
+ .I ICDDATE<3061001 D F
+ .E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q
 F I ICDJ=49 S ICDJ(1)=ICDJ Q
@@ -43,12 +42,4 @@
  I ICDJ=63 S ICDJ(17)=ICDJ Q
  Q
-FY2008 ;MS-DRG
- I ICDJ=130 S ICDJ(1)=ICDJ Q
- I ICDJ=132 S ICDJ(2)=ICDJ Q
- I ICDJ=134 S ICDJ(3)=ICDJ Q
- I ICDJ=136 S ICDJ(4)=ICDJ Q
- I ICDJ=138 S ICDJ(5)=ICDJ Q
- I ICDJ=139 S ICDJ(6)=ICDJ Q
- Q
 EN1 ;
  I $D(ICDOP(" 28.2"))!($D(ICDOP(" 28.3")))!($D(ICDOP(" 28.6"))) S ICDRG=$S(ICDOCNT>1:$S(AGE>17:57,1:58),1:ICDRG)
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG5.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG5.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG5.m	(revision 636)
@@ -1,8 +1,7 @@
 ICDDRG5 ;ALB/GRR/EG/MRY/ADL - FIX SURGERY HIERARCHY ; 3/20/03 10:36am
- ;;18.0;DRG Grouper;**2,5,7,10,20,22,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**2,5,7,10,20,22**;Oct 20, 2000;Build 1
  Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- .I ICDDATE<3051001 D F Q
- .E  I ICDDATE<3071001 D FY2007 Q
- .E  D FY2008
+ .I ICDDATE<3051001 D F
+ .E  D FY2006
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=103 S ICDJ(1)=ICDJ Q
@@ -33,5 +32,5 @@
  I ICDJ=120 S ICDJ(25)=ICDJ
  Q
-FY2007 ;
+FY2006 ;
  I ICDJ=103 S ICDJ(1)=ICDJ Q
  I ICDJ=525 S ICDJ(2)=ICDJ Q
@@ -66,28 +65,4 @@
  I ICDJ=120 S ICDJ(31)=ICDJ
  Q
-FY2008 ;
- I ICDJ=215 S ICDJ(1)=ICDJ Q
- I ICDJ=221 S ICDJ(2)=ICDJ Q
- I ICDJ=223 S ICDJ(3)=ICDJ Q
- I ICDJ=225 S ICDJ(4)=ICDJ Q
- I ICDJ=227 S ICDJ(5)=ICDJ Q
- I ICDJ=230 S ICDJ(6)=ICDJ Q
- I ICDJ=232 S ICDJ(7)=ICDJ Q
- I ICDJ=234 S ICDJ(8)=ICDJ Q
- I ICDJ=236 S ICDJ(9)=ICDJ Q
- I ICDJ=238 S ICDJ(10)=ICDJ Q
- I ICDJ=241 S ICDJ(11)=ICDJ Q
- I ICDJ=244 S ICDJ(12)=ICDJ Q
- I ICDJ=245 S ICDJ(13)=ICDJ Q
- I ICDJ=247 S ICDJ(14)=ICDJ Q
- I ICDJ=249 S ICDJ(15)=ICDJ Q
- I ICDJ=251 S ICDJ(16)=ICDJ Q
- I ICDJ=254 S ICDJ(17)=ICDJ Q
- I ICDJ=257 S ICDJ(18)=ICDJ Q
- I ICDJ=259 S ICDJ(19)=ICDJ Q
- I ICDJ=262 S ICDJ(20)=ICDJ Q
- I ICDJ=263 S ICDJ(21)=ICDJ Q
- I ICDJ=264 S ICDJ(22)=ICDJ Q
- Q
 EN1 S (ICDCC3,ICDCC2)=0
  I $D(ICDOP(" 00.50")) S ICDCC3=1
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG6.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG6.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG6.m	(revision 636)
@@ -1,8 +1,7 @@
 ICDDRG6 ;ALB/GRR - FIX SURGERY HIERARCHY ; 10/23/00 11:40am
- ;;18.0;DRG Grouper;**24,27,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**24,27**;Oct 20, 2000;Build 2
  Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D
- .I ICDDATE<3061001 D F Q
- .E  I ICDDATE<3071001 D FY2007 Q
- .E  D FY2008
+ .I ICDDATE<3061001 D F
+ .E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q
 F I ICDJ=154 S ICDJ(1)=ICDJ Q
@@ -40,15 +39,2 @@
  I ICDJ=170 S ICDJ(19)=ICDJ
  Q
-FY2008 ;
- I ICDJ=328 S ICDJ(1)=ICDJ Q
- I ICDJ=331 S ICDJ(2)=ICDJ Q
- I ICDJ=334 S ICDJ(3)=ICDJ Q
- I ICDJ=337 S ICDJ(4)=ICDJ Q
- I ICDJ=340 S ICDJ(5)=ICDJ Q
- I ICDJ=343 S ICDJ(6)=ICDJ Q
- I ICDJ=346 S ICDJ(7)=ICDJ Q
- I ICDJ=349 S ICDJ(8)=ICDJ Q
- I ICDJ=352 S ICDJ(9)=ICDJ Q
- I ICDJ=355 S ICDJ(10)=ICDJ Q
- I ICDJ=358 S ICDJ(11)=ICDJ Q
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG7.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG7.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG7.m	(revision 636)
@@ -1,7 +1,5 @@
 ICDDRG7 ;ALB/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:41am
- ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
- Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D
- .I ICDDATE<3071001 D F Q
- .E  D FY2008
+ ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
+ Q:$O(ICDODRG(0))'>0  K ICDJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  D F
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" K ICDJ Q
 F I ICDJ=191 S ICDJ(1)=ICDJ Q
@@ -19,11 +17,2 @@
  I ICDJ=201 S ICDJ(13)=ICDJ
  Q
-FY2008 ;
- I ICDJ=407 S ICDJ(1)=ICDJ Q
- I ICDJ=410 S ICDJ(2)=ICDJ Q
- I ICDJ=413 S ICDJ(3)=ICDJ Q
- I ICDJ=416 S ICDJ(4)=ICDJ Q
- I ICDJ=419 S ICDJ(5)=ICDJ Q
- I ICDJ=422 S ICDJ(6)=ICDJ Q
- I ICDJ=423 S ICDJ(7)=ICDJ Q
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG8.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG8.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG8.m	(revision 636)
@@ -1,9 +1,8 @@
 ICDDRG8 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 7/18/01 10:40am
- ;;18.0;DRG Grouper;**1,2,10,20,24,31**;Oct 20, 2000;Build 7
+ ;;18.0;DRG Grouper;**1,2,10,20,24**;Oct 20, 2000;Build 5
  Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- .I ICDDATE<3051001 D F Q
- .E  I ICDDATE<3061001 D FY2006 Q
- .E  I ICDDATE<3071001 D FY2007 Q
- .E  D FY2008
+ .I ICDDATE<3051001 D F
+ .E  I ICDDATE<3061001 D FY2006
+ .E  D FY2007
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=471 S ICDJ(1)=ICDJ Q
@@ -111,32 +110,4 @@
  I ICDJ=234 S ICDJ(37)=ICDJ Q
  Q
-FY2008 ;
- I ICDJ=455 S ICDJ(1)=ICDJ Q
- I ICDJ=458 S ICDJ(2)=ICDJ Q
- I ICDJ=460 S ICDJ(3)=ICDJ Q
- I ICDJ=462 S ICDJ(4)=ICDJ Q
- I ICDJ=465 S ICDJ(5)=ICDJ Q
- I ICDJ=468 S ICDJ(6)=ICDJ Q
- I ICDJ=470 S ICDJ(7)=ICDJ Q
- I ICDJ=473 S ICDJ(8)=ICDJ Q
- I ICDJ=476 S ICDJ(9)=ICDJ Q
- I ICDJ=479 S ICDJ(10)=ICDJ Q
- I ICDJ=482 S ICDJ(11)=ICDJ Q
- I ICDJ=484 S ICDJ(12)=ICDJ Q
- I ICDJ=487 S ICDJ(13)=ICDJ Q
- I ICDJ=489 S ICDJ(14)=ICDJ Q
- I ICDJ=491 S ICDJ(15)=ICDJ Q
- I ICDJ=494 S ICDJ(16)=ICDJ Q
- I ICDJ=497 S ICDJ(17)=ICDJ Q
- I ICDJ=499 S ICDJ(18)=ICDJ Q
- I ICDJ=502 S ICDJ(19)=ICDJ Q 
- I ICDJ=505 S ICDJ(20)=ICDJ Q
- I ICDJ=506 S ICDJ(21)=ICDJ Q
- I ICDJ=508 S ICDJ(22)=ICDJ Q
- I ICDJ=509 S ICDJ(23)=ICDJ Q
- I ICDJ=512 S ICDJ(24)=ICDJ Q
- I ICDJ=514 S ICDJ(25)=ICDJ Q
- I ICDJ=517 S ICDJ(26)=ICDJ Q
- Q
 EN1 ; paired spinal fusion codes
  S ICDCC3=0
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG9.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRG9.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRG9.m	(revision 636)
@@ -1,7 +1,5 @@
 ICDDRG9 ;ALB/GRR/EG - FIX SURGERY HIERARCHY ; 10/23/00 11:42am
- ;;18.0;DRG Grouper;**31**;Oct 20, 2000;Build 7
- Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D
- . I ICDDATE<3071001 D F Q
- .E  D FY2008
+ ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
+ Q:$O(ICDODRG(0))'>0  K ICDJ,ICDJJ F ICDJ=0:0 S ICDJ=$O(ICDODRG(ICDJ)) Q:ICDJ'>0  S ICDJJ(ICDJ)="" D F
 END S ICDJ=$O(ICDJ(0)) Q:ICDJ'>0  S ICDJ=ICDJ(ICDJ) K ICDODRG S ICDODRG(ICDJ)="" Q
 F I ICDJ=263 S ICDJ(1)=ICDJ Q
@@ -20,9 +18,2 @@
  I ICDJ=270 S ICDJ(14)=ICDJ
  Q
-FY2008 ;
- I ICDJ=575 S ICDJ(1)=ICDJ Q
- I ICDJ=578 S ICDJ(2)=ICDJ Q
- I ICDJ=581 S ICDJ(3)=ICDJ Q
- I ICDJ=583 S ICDJ(4)=ICDJ Q
- I ICDJ=585 S ICDJ(5)=ICDJ Q
- Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRGM.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRGM.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRGM.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDDRGM ;ALB/GRR/EG/ADL - GROUPER DRIVER ; 10/23/00 11:45am
- ;;18.0;DRG Grouper;**7**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1
  ;;ADL;Add Date prompt and passing of effective date for DRG CSV project
  ;;ADL;Update DIC("S") code to screen using new function calls
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRGX.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDDRGX.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDDRGX.m	(revision 636)
@@ -1,6 +1,5 @@
-ICDDRGX ;ALB/EG/MRY/ADL - GROUPER PROCESS ; 11/13/07 3:44pm
- ;;18.0;DRG Grouper;**1,2,5,7,10,14,20,24,27,31**;Oct 20, 2000;Build 7
+ICDDRGX ;ALB/EG/MRY/ADL - GROUPER PROCESS ; 3/14/05 1:38pm
+ ;;18.0;DRG Grouper;**1,2,5,7,10,14,20,24,27**;Oct 20, 2000;Build 2
 CKHIV ;MDC25 grouping
- I ICDDATE>3070930.9 G CKHIV^ICDDRGXM ;MS-DRG
  ;Q:ICDP25=""
  I ICDPD'["h"&(ICDSD'["h") Q
@@ -26,26 +25,17 @@
  S:(ICDRG=488)!(ICDRG=489)!(ICDRG=490) ICDRTC=0
  K ICDGH,ICDP25,ICDS25,ICDORNA Q
-CKMST ;MDC24 grouping; MS-DRG additions
+CKMST ;MDC24 grouping
  S ICDAJ=0 F ICDS24K=1:1 S ICDAJ=$O(ICDS24(ICDAJ)) Q:ICDAJ=""
  S ICDS24K=ICDS24K-1,ICDS24L=0 F ICDI=1:1:8 S:$D(ICDS24(ICDI))&(ICDI'=ICDP24) ICDS24L=$S($D(ICDS24(ICDI)):1,1:0)
  I ICDOR["u" S ICDS24K=ICDS24K+1
  G:((ICDP24=0)&(ICDS24K<2))!((ICDP24>0)&('ICDS24L)) CKMSTE
- N CKMST S CKMST=0
- I ICDDATE>3070930.9 D  Q:CKMST  ;MS-DRG
- . S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):955,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):955,1:ICDRG) I ICDRG=955 D CKMSTE S CKMST=1 Q
- . S:ICDRG'=955 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):956,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):956,1:ICDRG) I ICDRG=956 D CKMSTE S CKMST=1 Q
- . S:ICDRG'=956 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):959,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):959,1:ICDRG) I ICDRG=959 D CKMSTE S CKMST=1 Q
- . S ICDRG=$S(ICDP24=0&(ICDS24K>1):965,ICDP24>0&ICDS24L:965,1:ICDRG)
- . S:(ICDRG>954)&(ICDRG<966) ICDRTC=0
- E  D  Q:CKMST  ;CMS-DRG
- . S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):484,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):484,1:ICDRG) I ICDRG=484 D CKMSTE S CKMST=1 Q
- . S:ICDRG'=484 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):485,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):485,1:ICDRG) I ICDRG=485 D CKMSTE S CKMST=1 Q
- . S:ICDRG'=485 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):486,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):486,1:ICDRG) I ICDRG=486 D CKMSTE S CKMST=1 Q
- . S ICDRG=$S(ICDP24=0&(ICDS24K>1):487,ICDP24>0&ICDS24L:487,1:ICDRG)
- . S:(ICDRG>483)&(ICDRG<488) ICDRTC=0
+ S ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(1))):484,ICDP24>0&($D(ICDO24(1)))&(ICDS24L):484,1:ICDRG) I ICDRG=484 D CKMSTE Q
+ S:ICDRG'=484 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(2))):485,ICDP24>0&($D(ICDO24(2)))&(ICDS24L):485,1:ICDRG) I ICDRG=485 D CKMSTE Q
+ S:ICDRG'=485 ICDRG=$S(ICDP24=0&(ICDS24K>1)&($D(ICDO24(3))):486,ICDP24>0&($D(ICDO24(3)))&(ICDS24L):486,1:ICDRG) I ICDRG=486 D CKMSTE Q
+ S ICDRG=$S(ICDP24=0&(ICDS24K>1):487,ICDP24>0&ICDS24L:487,1:ICDRG)
+ S:(ICDRG>483)&(ICDRG<488) ICDRTC=0
 CKMSTE K ICDAJ,ICDP24,ICDS24,ICDO24,ICDS24K,ICDO24,ICDS24L
  Q
 CKNMDC ;non MDC drg's
- I ICDDATE>3070930.9 G CKNMDC^ICDDRGXM ;MS-DRG
  S:(ICDRG>479)&(ICDRG<484) ICDRG=470
  ; ICD*18*1 - reorder drg 103 higher than all Pre-MDCs 480-83 & 495
@@ -65,5 +55,5 @@
  S ICDRG=$S(ICDOR["r":495,1:ICDRG) I ICDRG=495 S ICDRTC=0 Q  ;check for lung tx
  S ICDRG=$S(ICDOR["q":103,1:ICDRG) I ICDRG=103 S ICDRTC=0 Q  ;check for heart tx
- S ICDRG=$S(ICDOR["B":481,1:ICDRG) I ICDRG=481 S ICDRTC=0 Q
+ S ICDRG=$S(ICDOR["B":481,1:ICDDRG) I ICDRG=481 S ICDRTC=0 Q
  S ICDRG=$S($D(ICDOP(" 30.3"))!$D(ICDOP(" 30.4")):482,1:ICDRG) I ICDRG=482 S ICDRTC=0 Q
  S ICDRG=$S(ICDOR["t"&($P($$ICDDX^ICDCODE(ICDDX(1),ICDDATE),"^",3)["Y"):482,1:ICDRG) I ICDRG=482 S ICDRTC=0 Q
@@ -72,11 +62,6 @@
  ;
 CHKMDC4 ;MDC 4 drg's
- I ICDDATE>3070930.9 D  ;MS-DRG
- . I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=168
- . I ICDDRG=983,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=264
- . I ICDDRG=983,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=264 ;ICD*18*5
- E  D  ;CMS-DRG
- . I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=76
- . I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=120
- . I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=120 ;ICD*18*5
+ I (ICDMDC=4!(ICDMDC=98)),(ICDOR["f") S ICDRG=76
+ I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 86.06")) S ICDRG=120
+ I ICDDRG=468,$G(ICDMDC)=5,$D(ICDOP(" 92.27")),ICDNOR=1 S ICDRG=120 ;ICD*18*5
  Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDGTDRG.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDGTDRG.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDGTDRG.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDGTDRG  ;ALB/ADL/KER - COLLECTION OF DRG APIS ; 04/18/2004
- ;;18.0;DRG Grouper;**7,12,14,17**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**7,12,14,17**;Oct 20, 2000;Build 1
  ;   Collection of API's for accessing new "DRG" level
  ;   of files #80, #80.1, and #80.2.  These new levels
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDHLPO.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDHLPO.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDHLPO.m	(revision 636)
@@ -1,4 +1,4 @@
-ICDHLPO ;ALB/GRR/EG-HELP DISPLAY FOR OPERATION IDENTIFIERS ; 11/9/07 12:52pm
- ;;18.0;DRG Grouper;**10,14,31**;Oct 20, 2000;Build 7
+ICDHLPO ;ALB/GRR/EG-HELP DISPLAY FOR OPERATION IDENTIFIERS ; 9/22/04 9:38am
+ ;;18.0;DRG Grouper;**10,14**;Oct 20, 2000;Build 1
 EN ;revised 12/94  abr
  N ICDID,I,J,ID
@@ -57,5 +57,4 @@
  ;;Q=Craniotomy
  ;;I=injectable/infusion (injection or infusion of drugs)
- ;;J=Inguinal and femoral hernia procedures
  ;;EXIT
  Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDID.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDID.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDID.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDID ;SLC/KER - ICD IDENTIFIERS ; 04/18/2004
- ;;18.0;DRG Grouper;**12,15**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**12,15**;Oct 20, 2000;Build 1
  ;
  ;
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDREF.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDREF.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDREF.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDREF ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 5/20/05 8:35pm
- ;;18.0;DRG Grouper;** 14,17 **;Oct 20, 2000
+ ;;18.0;DRG Grouper;** 14,17 **;Oct 20, 2000;Build 1
 RTABLE(ICDRG,ICDDATE) ; Return Reference Table
  ;  Input:      ICDRG - DRG entry
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDSUPT.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDSUPT.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDSUPT.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDSUPT ;DLS/DEK - ICD SUPPORT FOR APIS ; 04/28/2003
- ;;18.0;DRG Grouper;**6**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**6**;Oct 20, 2000;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB1.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB1 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/29/03 11:47am
- ;;18.0;DRG Grouper;**10**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**10**;Oct 20, 2000;Build 1
 DRG1 D DRG528 D:ICDRG'=528 DRG529
  S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1A.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB1A.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1A.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB1A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 8/19/04 3:19pm ; 6/15/05 6:35pm
- ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000;Build 1
 DRG1 D DRG528 D:ICDRG'=528 DRG543^ICDTLB6A D:ICDRG'=543 DRG529
  S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=543:543,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1B.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB1B.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB1B.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB1B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 8/19/04 3:19pm ; 6/28/05 4:01pm
- ;;18.0;DRG Grouper;**20**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1
 DRG1 D DRG528 D:ICDRG'=528 DRG543^ICDTLB6B D:ICDRG'=543 DRG529
  S ICDRG=$S(AGE<18:3,ICDRG=528:528,ICDRG=543:543,ICDRG=529:529,ICDRG=530:530,ICDCC:1,1:2) I AGE="" S ICDRTC=3,ICDRG=470
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB2.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB2 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/19/03 1:09pm
- ;;18.0;DRG Grouper;**2,10**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**2,10**;Oct 20, 2000;Build 1
 DRG95 S ICDRG=$S(ICDCC:94,1:95) Q
 DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2A.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB2A.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2A.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB2A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 9/19/03 1:09pm ; 11/19/04 10:13am
- ;;18.0;DRG Grouper;**14**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1
 DRG95 S ICDRG=$S(ICDCC:94,1:95) Q
 DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2B.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB2B.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB2B.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB2B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 9/19/03 1:09pm ; 6/28/05 4:02pm
- ;;18.0;DRG Grouper;**20**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1
 DRG95 S ICDRG=$S(ICDCC:94,1:95) Q
 DRG96 S ICDRG=$S(AGE<18:98,ICDCC:96,1:97) I AGE="" S ICDRG=470,ICDRTC=3
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB3.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB3 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 9/29/04 3:38pm
- ;;18.0;DRG Grouper;**14**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1
 DRG164 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
 DRG165 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3A.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB3A.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB3A.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB3A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:48am ; 4/1/05 11:05am
- ;;18.0;DRG Grouper;**14,16**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14,16**;Oct 20, 2000;Build 1
 DRG164 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
 DRG165 S ICDRG=$S(ICDPD["X"&(ICDCC):164,ICDPD["X":165,ICDCC:166,1:167) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB4.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB4 ;ALB/EG - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:48am
- ;;18.0;DRG Grouper;;Oct 20, 2000
+ ;;18.0;DRG Grouper;;Oct 20, 2000;Build 1
 DRG263 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q
 DRG264 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4A.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB4A.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4A.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB4A ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:48am ; 10/4/04 10:23am
- ;;18.0;DRG Grouper;**14**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1
 DRG263 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q
 DRG264 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4B.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB4B.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB4B.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB4B ;ALB/EG - GROUPER UTILITY FUNCTIONS FY 2006; 10/23/00 11:48am ; 6/28/05 4:04pm
- ;;18.0;DRG Grouper;**20**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1
 DRG263 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q
 DRG264 S ICDRG=$S(ICDPD["U"&(ICDCC):263,ICDPD["U":264,ICDCC:265,1:266) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB5.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB5 ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS ; 10/23/00 11:49am
- ;;18.0;DRG Grouper;**7**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**7**;Oct 20, 2000;Build 1
  ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
 DRG334 S ICDRG=$S(ICDCC:334,1:335) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5A.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB5A.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5A.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB5A ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS FY 2005; 10/23/00 11:49am ; 8/23/04 11:31am
- ;;18.0;DRG Grouper;**14**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14**;Oct 20, 2000;Build 1
  ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
 DRG334 S ICDRG=$S(ICDCC:334,1:335) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5B.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB5B.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB5B.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB5B ;ALB/EG/ADL - GROUPER UTILITY FUNCTIONS FY 2006; 10/23/00 11:49am ; 6/28/05 4:05pm
- ;;18.0;DRG Grouper;**20**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**20**;Oct 20, 2000;Build 1
  ;;ADL;UPDATE FOR CSV PROJECT;Mar 12, 2003
 DRG334 S ICDRG=$S(ICDCC:334,1:335) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB6.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB6 ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS ; 9/29/03 2:47pm
- ;;18.0;DRG Grouper;**2,5,10**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**2,5,10**;Oct 20, 2000;Build 1
 DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
 DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB61.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB61.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB61.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB61 ;SSI/ALA-GROUPER UTILITY FUNCTIONS [ 10/9/03  6:28 PM ] ; 10/23/00 11:50am
- ;;18.0;DRG Grouper;**10,22**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**10,22**;Oct 20, 2000;Build 1
 DRG412 ;
  I $D(ICDDX(1))&(ICDOPCT=0) D  Q:ICDRG=409
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6A.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB6A.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6A.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB6A ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS FY 2005; 9/29/03 2:47pm ; 6/16/05 1:31pm
- ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**14,17**;Oct 20, 2000;Build 1
 DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
 DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
Index: FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6B.m
===================================================================
--- FOIAVistA/trunk/r/DRG_GROUPER-ICD--ICPT/ICDTLB6B.m	(revision 631)
+++ FOIAVistA/tag/r/DRG_GROUPER-ICD--ICPT/ICDTLB6B.m	(revision 636)
@@ -1,4 +1,4 @@
 ICDTLB6B ;ALB/EG/MRY - GROUPER UTILITY FUNCTIONS FY 2006; 9/29/03 2:47pm ; 6/28/05 4:06pm
- ;;18.0;DRG Grouper;**20,22**;Oct 20, 2000
+ ;;18.0;DRG Grouper;**20,22**;Oct 20, 2000;Build 1
 DRG403 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
 DRG404 S ICDRG=$S(ICDPD["l":$S(AGE="":470,AGE<18:405,1:473),ICDOR["O"!(ICDORNI["O"):$S(ICDCC:401,1:402),ICDCC:403,1:404),ICDRTC=$S(ICDRG=470:3,1:ICDRTC) Q
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU3.m	(revision 636)
@@ -1,4 +1,4 @@
 PSABRKU3 ;BIR/JMB/PDW-Upload and Process Prime Vendor Invoice Data - CONT'D ;8/13/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,41,47,67**; 10/24/97;Build 15
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,41,47**; 10/24/97
  ;Checking the X12 invoice data.
  S (PSASTCNT,PSAITCNT,PSACTRL(1))=0
@@ -73,10 +73,4 @@
 IT1 .;invoice line item
  .I PSALAST="IT1" S PSASTCNT=PSASTCNT+1,PSAITCNT=PSAITCNT+1 D ITEM Q
- .;BGN PSA*3*67
-PID .;generic vendor item name
- .I PSALAST="PID" S PSASTCNT=PSASTCNT+1,$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",29)=$S($P(PSADATA,"^",6)=$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",28):"Unknown",1:$P(PSADATA,"^",6)) Q
-PO4 .;DESCRIPTION OF ITEM
- .I PSALAST="PO4" S PSASTCNT=PSASTCNT+1,$P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",30)=$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",9) D  Q
- .;END PSA*3*67
 CTT .;item count
  .I PSALAST="CTT" S PSASTCNT=PSASTCNT+1 D  Q
@@ -99,7 +93,4 @@
  S PSAITEM=+$P(PSADATA,"^",2),^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM)=+$P(PSADATA,"^",3)_"^"_$P(PSADATA,"^",4)_"^"_$P(PSADATA,"^",5)_"^"_$P(PSADATA,"^",8)_"^"_$P(PSADATA,"^",10)
  I $P(PSADATA,"^",12)'="",$P(PSADATA,"^",11)="UP" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",26)=$P(PSADATA,"^",12)
- ;Next line to add vendor Generic Description
- I $P(PSADATA,"^",14)'="" S $P(^TMP($J,"PSAPV SET",PSACTRL,"IT",PSAITEM),"^",28)=$P(PSADATA,"^",14)
- ;Eop67
  Q
 RESETST ;Reset PSACTRL
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSABRKU5.m	(revision 636)
@@ -1,7 +1,18 @@
-PSABRKU5 ;BIR/DB-Upload and Process Prime Vendor Invoice Data - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26,67**; 10/24/97;Build 15
+PSABRKU5 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;7/23/97
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**26**; 10/24/97
  ;This routine checks for correct X12 formating.
  ;
 ORDER ;  check order of code sheets
+ ;  isa   <--------------+
+ ;    gs    <----------+ |
+ ;      st    <------+ | |
+ ;      | big        | | |
+ ;      | it1   <--+ | | |
+ ;      | ...      | | | |--repeats
+ ;      | it1   <--+ | | |
+ ;      | ctt        | | |
+ ;      se    <------+ | |
+ ;    ge    <----------+ |
+ ;  iea   <--------------+
  S PSANEXT=$P(PSADATA,"^")
  ;
@@ -20,8 +31,6 @@
  I PSALAST="ST",PSANEXT'="BIG" D ORDERROR("ST",PSANEXT,"BIG") Q
  ;
- ;adding next two lines for new format
- I PSALAST="IT1",PSANEXT="PID" Q
- I PSALAST="PO4",PSANEXT'="IT1",PSANEXT'="CTT"&(PSANEXT'="TDS") D ORDERROR("PO4",PSANEXT,"CTT") Q
- ;End of PSA*3*67 Changes
+ I PSALAST="IT1",PSANEXT="IT1" Q
+ I PSALAST="IT1",PSANEXT'="CTT"&(PSANEXT'="TDS") D ORDERROR("IT1",PSANEXT,"CTT") Q
  Q
  ;
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAENTO.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAENTO ;BIR/LTL,JMB-Set Up/Edit a Pharmacy Location - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,43,63**; 10/24/97;Build 10
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,43**; 10/24/97
  ;This routines is called by PSAENT.
  ;
@@ -34,5 +34,5 @@
  S:'$D(PSALOC) PSALOC=$O(^PSD(58.8,"AOP",+PSAOSIT,"")),PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U)
 OPC W !!,"Outpatient site selection affects the collection of dispensing data.",!
- S DIE="^PSD(58.8,",DA=PSALOC,DR="20//^S X=$P($G(^PS(59,+PSAOSIT,0)),U)" D ^DIE K DIE I $D(DTOUT)!($D(Y)) G QUIT  ;; <3*63 RJS>
+ S DIE="^PSD(58.8,",DA=PSALOC,DR="20//^S X=$P($G(^PS(59,+PSAOSIT,0)),U)" D ^DIE K DIE G:$D(Y) QUIT
  S PSAOSIT=+$P($G(^PSD(58.8,PSALOC,0)),"^",10)
  G:'PSALOC QUIT
@@ -55,5 +55,5 @@
  ...S ^PSD(58.8,+PSALOC,1,+PSADRUG,5,0)="^58.801A^^"
  ...S DIC="^PSD(58.8,+PSALOC,1,+PSADRUG,5,",DIC(0)="LM",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRUG,DIC("DR")="1////^S X=$G(PSAQTY);5////^S X=$G(PSAQTY)",DLAYGO=58.8 D ^DIC K DIC,DLAYGO
- ...F  L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
+ ...F  L +^PSD(58.81,0):0 I  Q
 FIND ...S PSAT=$P(^PSD(58.81,0),U,3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),U,3)=$P(^PSD(58.81,0),U,3)+1 G FIND
  ...S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DLAYGO L -^PSD(58.81,0)
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAORDP1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAORDP1 ;BIR/JMB-Print Orders - CONT'D ;9/19/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65,67**; 10/24/97;Build 15
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,21,61,65**; 10/24/97;Build 2
  ;This routine prints invoices.
  ;
@@ -124,7 +124,4 @@
  .W:+$P($G(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2)),"^",2)'=0 !?9,"REORDER LEVEL: "_$FN(+$P(^PSD(58.811,PSAORD,1,PSAINV,1,PSALN,2),"^",2),",")
  .;
- .;BGN 67
- .D DISP2^PSAP67
- .;END 67
  .I $Y+5>IOSL D:$E(IOST,1,2)="C-" SCREEN^PSAORDP2 Q:PSAOUT  D HEADER^PSAORDP2 D LINEHDR^PSAORDP2
  .D ^PSAORDP2 Q:PSAOUT
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC4.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAPROC4 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,63**; 10/24/97;Build 10
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21**; 10/24/97
  ;References to ^PSDRUG( are covered by IA #2095
  ;References to ^DIC(51.5 are covered by IA #1931
@@ -52,17 +52,11 @@
  ;
 LIST Q:PSANODE=""!($P($G(^PSDRUG(PSAIEN50,0)),"^")="")
- ;3*63 RJS
- N PSAPPOU,PSADUOU,PSAPPDU,PSAVEND,PSAOU,PSACPPDU,X,PSANDC,PSADU,PSASYNM,PSAVSN
- S X=PSANODE
- S PSASYNM=$P(X,U,1),PSANDC=$P(X,U,2),PSAVSN=$P(X,U,4),PSAOU=+$P(X,U,5),PSAPPOU=$P(X,U,6)
- S PSADUOU=$P(X,U,7),PSAPPDU=$P(X,U,8),PSAVEND=$P(X,U,9)
- S PSADU=$$GET1^DIQ(50,PSAIEN50,14.5),PSAOU=$P($G(^DIC(51.5,PSAOU,0)),"^")
- S PSACPPDU=$S('PSADUOU:"BLANK",1:(PSAPPOU*1000/PSADUOU\1/1000)) ;recalculate PPDU, file doesn't reset PPDU
  W !?1,PSAMENU_".",?4,$P($G(^PSDRUG(PSAIEN50,0)),"^") I $D(^PSDRUG(PSAIEN50,"I")) W ?60,"(INACTIVE)"
- I PSANDC="",PSAVSN="" W !,?19,"SYN #",PSASYN,": ",PSASYNM,! Q
- W !,?4,"NDC: ",PSANDC,?25,"Order Unit: ",PSAOU,?46,"Price Per Order Unit: $",$FN(PSAPPOU,",",2)
- W !,?4,"VSN: ",PSAVSN,?19,"SYN #",PSASYN,": ",PSASYNM,?42,"Dose Unit Per Order Unit: ",PSADUOU
- W !,?4,"Vendor: ",PSAVEND,?47,"Price Per Dose Unit: ",$FN(PSACPPDU,","),!
- ;3*63 end
+ ;NOIS CTX-1200-71091 (PSA*3*21 Dave B)
+ I $P(PSANODE,"^",2)'="" W !,?4,"NDC : "_$P(PSANODE,"^",2)
+ I +$P(PSANODE,"^",5),$P($G(^DIC(51.5,+$P(PSANODE,"^",5),0)),"^")'="" W !?4,"Order Unit: "_$P(^DIC(51.5,+$P(PSANODE,"^",5),0),"^"),?45,"Price Per Order Unit   : $"_$S(+$P(PSANODE,"^",6):$P(PSANODE,"^",6),1:"(Blank)")
+ E  I +$P(PSANODE,"^",6) W !?4,"Price Per Order Unit: $"_$P(PSANODE,"^",6)
+ I $P(PSANODE,"^",9)'="" W !?4,"Vendor: "_$P(PSANODE,"^",9),?45,"VSN: "_$S($P(PSANODE,"^",4)'="":$P(PSANODE,"^",4),1:"(Blank)")
+ E  I $P(PSANODE,"^",4)'="" W !?4,"VSN: "_$S($P(PSANODE,"^",4)'="":$P(PSANODE,"^",4),1:"(Blank)")
  Q
  ;
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC7.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC7.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAPROC7.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAPROC7 ;BIR/JMB-Process Uploaded Prime Vendor Invoice Data - CONT'D ;9/6/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64,67**; 10/24/97;Build 15
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,27,21,42,61,64**; 10/24/97;Build 4
  ;This routine takes the data in XTMP and moves it to DA ORDERS file.
  ;It deletes the data in XTMP after it is copies.
@@ -65,10 +65,4 @@
  S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",6)=DT
  S $P(^PSD(58.811,DA(2),1,DA(1),1,DA,0),"^",7)=DUZ
- ;BGN 67
- S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",1)=$P(PSADATA,"^",28)
- S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",2)=$P(PSADATA,"^",29)
- S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",3)=$P(PSADATA,"^",30)
- S $P(^PSD(58.811,DA(2),1,DA(1),3,DA,0),"^",4)=$P(PSADATA,"^",31)
- ;END 67
  S DIK=DIE D IX^DIK
  ;End PSA*3*7
@@ -81,7 +75,4 @@
  I +$P(PSADATA,"^",7)!(+$P(PSADATA,"^",20))!(+$P(PSADATA,"^",21))!(+$P(PSADATA,"^",27)) D
  .S ^PSD(58.811,PSAIEN,1,PSAIEN1,1,PSAIEN2,2)=$P(PSADATA,"^",20)_"^"_$P(PSADATA,"^",21)_"^"_$S(+$P(PSADATA,"^",7):+$P(PSADATA,"^",7),1:0)_"^"_+$P(PSADATA,"^",27)
- ;Bgn 67
- I $P(PSADATA,"^",5)'="" S ^XTMP("PSAVSN",$P(PSADATA,"^",5))=$P(PSADATA,"^",28)_"^"_$P(PSADATA,"^",29)_"^"_$P(PSADATA,"^",30)_"^"_$P(PSADATA,"^",31)
- ;End 67
  K ^XTMP("PSAPV",PSACTRL,"IT",PSALINE)
  Q
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUDP.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAUDP ;BIR/LTL,JMB-Nightly Background Job - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64,66**; 10/24/97;Build 2
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**6,3,12,14,25,64**; 10/24/97;Build 4
  ;
  ;Reference to ^PS(57.6 are covered by IA #772
@@ -47,5 +47,4 @@
  S DIE="^PSD(58.8,PSALOC,1,PSA50,5,",DA(2)=PSALOC,DA(1)=PSA50,DA=$E(PSADT,1,5)*100,DR="9////^S X=$P($G(^(0)),U,6)+PSAQTY" D ^DIE K DIE,DA
  ;Get next transaction node number
- F  L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q  ;; << *66 RJS
 FIND S PSANUM=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSANUM)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
  ;Add next transaction node with data.
@@ -53,5 +52,4 @@
  S DIE="^PSD(58.81,",DA=PSANUM
  S DR="1////2;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSA50;5////^S X=PSAQTY;9////^S X=$G(PSABAL)" D ^DIE K DIE,DA
- L -^PSD(58.81,0)  ;; >> *66 RJS
  ;Add activity node
  S DIC="^PSD(58.8,PSALOC,1,PSA50,4,",DIC(0)="L",(X,DINUM)=PSANUM,DIC("P")=$P(^DD(58.8001,19,0),"^",2),DA(2)=PSALOC,DA(1)=PSA50,DLAYGO=58.8 D ^DIC K DA,DIC,DLAYGO
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUP4.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAUP4 ;BIR/JMB-Upload and Process Prime Vendor Invoice Data - CONT'D ;9/19/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,20,21,67**; 10/24/97;Build 15
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,20,21**; 10/24/97
  ;This routine prints invoices from the ^XTMP global on the screen or
  ;to a printer.
@@ -112,5 +112,5 @@
  .I $Y+9>IOSL,+$P(PSADATA,"^",21),+$P(PSADATA,"^",27) D:$E(IOST,1,2)="C-" SCREEN Q:PSAOUT  D HEADER,LINEHDR
  .I $G(PSADRG) D HAVEDRG
- .I '$G(PSADRG) W !?9,"STOCK LEVEL  : ",!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21),!?9,"DISPENSE UNITS/ORDER UNIT: " D DISP^PSAP67
+ .I '$G(PSADRG) W !?9,"STOCK LEVEL  : ",!?9,"REORDER LEVEL: "_$P(PSADATA,"^",21),!?9,"DISPENSE UNITS/ORDER UNIT: "
  .;
  .;Print Adj Qty
@@ -174,4 +174,3 @@
  W !?9,"DISPENSE UNITS/ORDER UNIT: "
  W $S(+$P(PSADATA,"^",20):+$P(PSADATA,"^",20),+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7):+$P($G(^PSDRUG(PSADRG,1,+$P(PSADATA,"^",7),0)),"^",7),1:"")
- D DISP^PSAP67
  Q
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAUTL1 ;BIR/JMB-Prime Vendor Invoice Data Utility ;9/19/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,15,21,48,49,54,67**; 10/24/97;Build 15
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,12,15,21,48,49,54**; 10/24/97
  ;This routine contains utilities to get the location name, display an
  ;error-free item, display an item with errors, and display a line ready
@@ -51,12 +51,14 @@
  W !,"Unit Price  : $"_$P(PSADATA,"^",3),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),!
  I $P(PSADATA,U,13)=.5 D  ;*48 AUTO OU UPDATE FOR MCKESSON
- .W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability"
- .W !,"      during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<"
- ;bgn *67
- W !,"PV-Drug-Description  : ",$S($P(PSADATA,"^",28)'="":$P(PSADATA,"^",28),1:"Unknown")
- W ?55,"PV-DUOU  : ",$S($P(PSADATA,"^",31)'="":$P(PSADATA,"^",31),1:"Unknown")
- W !,"PV-Drug-Generic Name : ",$S($P(PSADATA,"^",29)'="":$P(PSADATA,"^",29),1:"Unknown")
- W ?55,"PV-UNITS : ",$S($P(PSADATA,"^",30)'="":$P(PSADATA,"^",30),1:"Unknown"),!
- ;end *67
+ . W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability"
+ . W !,"      during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<"
+ ;*54 display VSN XTMP Drug Description and DUOU >==>
+ N PSAFLDT S PSAFLDT="February 2006"
+ N XXX S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D
+ . I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4)
+ . W !,"PV-Drug-Descrip: "
+ . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q
+ . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,!
+ ;*54 display VSN XTMP Drug Description and DUOU <==<
  W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank")
  W !,"Dispense Units Per Order Unit: "_$S($P(PSADATA,"^",20):+$P(PSADATA,"^",20),+PSASUB&(+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7)):+$P($G(^PSDRUG(+PSAIEN,1,PSASUB,0)),"^",7),1:"Blank")
@@ -98,13 +100,14 @@
  W !,"Unit Price  : $"_$S($G(PSAPRICE):PSAPRICE,PSAPRICE=0:0,1:"Blank"),?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),!
  I $P(PSADATA,U,13)=.5 D  ;*48 AUTO OU UPDATE FOR MCKESSON
- .N PSAOU S PSAOU=$P(PSADATA,U,12)
- .W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability"
- .W !,"      during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<"
- ;bgn *67
- W !,"PV-Drug-Description  : ",$S($P(PSADATA,"^",28)'="":$P(PSADATA,"^",28),1:"Unknown")
- W ?55,"PV-DUOU  : ",$S($P(PSADATA,"^",31)'="":$P(PSADATA,"^",31),1:"Unknown")
- W !,"PV-Drug-Generic Name : ",$S($P(PSADATA,"^",29)'="":$P(PSADATA,"^",29),1:"Unknown")
- W ?55,"PV-UNITS : ",$S($P(PSADATA,"^",30)'="":$P(PSADATA,"^",30),1:"Unknown"),!
- ;end *67
+ . N PSAOU S PSAOU=$P(PSADATA,U,12)
+ . W !,"*****>",!,"Note: The order unit was changed from EACH to ",$P($G(^DIC(51.5,+PSAOU,0)),"^")," by Drug Accountability"
+ . W !,"      during the upload of the invoiced data. Adjustments may be necessary.",!,"*****<"
+ N PSAFLDT S PSAFLDT="February 2006"
+ N XXX S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D
+ .I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4)
+ . W !,"PV-Drug-Descrip: "
+ . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q
+ . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,!
+ ;*54 display VSN XTMP Drug Description and DUOU <==<
  S PSAIN=^XTMP("PSAPV",PSACTRL,"IN"),PSALOC=$S($P(PSADATA,"^",19)="CS":+$P(PSAIN,"^",12),1:+$P(PSAIN,"^",7))
 DU W !,"Dispense Units: "_$S(+PSAIEN&($P($G(^PSDRUG(+PSAIEN,660)),"^",8)'=""):$P($G(^PSDRUG(+PSAIEN,660)),"^",8),1:"Blank")
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAUTL4.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAUTL4 ;BIR ISC/JMB-Verify Invoices Utility ; 8/19/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,48,54,61,67**; 10/24/97;Build 15
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,21,48,54,61**; 10/24/97;Build 1
  ;
  ;References to ^DIC(51.5 are covered by IA #1931
@@ -62,11 +62,12 @@
 VSN S:$D(PSADATA) PSAVSN=$P(PSADATA,"^",12) ;*48
  W ?38,"VSN: "_$S(PSAVSN'="":PSAVSN,1:"Blank"),!
- ;bgn *67
- S PSAP67=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,3,PSALINE,0))
- W !,"PV-Drug-Description  : ",$S($P(PSAP67,"^",1)'="":$P(PSAP67,"^",1),1:"Unknown")
- W ?55,"PV-DUOU  : ",$S($P(PSAP67,"^",4)'="":$P(PSAP67,"^",4),1:"Unknown")
- W !,"PV-Drug-Generic Name : ",$S($P(PSAP67,"^",2)'="":$P(PSAP67,"^",2),1:"Unknown")
- W ?55,"PV-UNITS : ",$S($P(PSAP67,"^",3)'="":$P(PSAP67,"^",3),1:"Unknown"),!
- ;end *67
+ ;*54 display VSN XTMP Drug Description and DUOU |==>
+ N PSAFLDT S PSAFLDT="February 2006"
+ N XXX I PSAVSN'="" S XXX=$G(^XTMP("PSAVSN",PSAVSN)) D
+ . I $G(^XTMP("PSAVSN",0)) S PSAFLDT=$P(^XTMP("PSAVSN",0),"^",4)
+ . W !,"PV-Drug-Descrip: "
+ . I '$L(XXX) W "Not Available. Item is OTC or new after ",PSAFLDT,! Q
+ . W ?20,$P(XXX,"~",2),?55,"PV-DUOU: ",+XXX,!
+ ;*54 display VSN XTMP Drug Description and DUOU <==|
 VDU S PSADUOU=+$P(PSATEMP,"^"),PSAREORD=+$P(PSATEMP,"^",2),PSASUB=+$P(PSATEMP,"^",3),PSASTOCK=+$P(PSATEMP,"^",4)
  W !,"Dispense Units: "_$S($P($G(^PSDRUG(+PSADRG,660)),"^",8)'="":$P($G(^PSDRUG(+PSADRG,660)),"^",8),1:"Blank")
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVER7.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAVER7 ;BIR/JMB-Verify Invoices - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64,66**; 10/24/97;Build 2
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**12,21,42,56,64**; 10/24/97;Build 4
  ;Background Job
  ;This routine increments pharmacy location and master vault balances
@@ -43,5 +43,5 @@
  S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit
  ;PSA*3*42 |>  (let changes happen and file, put changes into mail message)
- S DIE="^PSDRUG(",(DA,OLDDA)=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;Q;13////^S X=PSAPOU" ;*42;*56
+ S DIE="^PSDRUG(",DA=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU;Q;13////^S X=PSAPOU" ;*42;*56
  F  L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
  D ^DIE K DIE,DA,DR
@@ -64,7 +64,6 @@
  .F  L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
  .D ^DIE L -^PSDRUG(DA,0) K DIE,DA,DR
-SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file  >>*66 RJS
- G:PSANDC="" END
- S DA(1)=PSADRG  ;;  << *66 RJS
+SYNONYM ;Adds/edits the SYNONYM multiple in DRUG file
+ Q:PSANDC=""  K DA,DR S DA(1)=PSADRG
  ;
  S PSANPDU=$J(($G(PSAPOU)/$G(PSADUOU)),0,3) ;Price of Order Unit divide by Disp. Units per Order Unit
@@ -92,5 +91,3 @@
  D ^DIE L -^PSDRUG(PSADRG,0)
  K DIE,DR,X1,X2,DATA
-END ; FINAL CLEANUP  << *66 RJS
- L -^PSDRUG(OLDDA,0) K OLDDA  ;; >> *66 RJS
  Q
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAVERA ;BHM/DBM - Change verified invoice data;16AUG05
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53,63**; 10/24/97;Build 10
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,36,40,53**; 10/24/97
  ;
  ;References to ^DIC(51.5 are covered by IA #1931
@@ -11,11 +11,14 @@
 INV ;Get Invoice Number
  S DIC(0)="AEQMZ",DIC("A")="Select Invoice Number: ",DIC="^PSD(58.811,"_PSAIEN_",1,",D="ASTAT" D ^DIC K DIC G Q:+Y'>0 S PSAIEN1=+Y,PSAINV=$P(Y,U,2)
+ ;
  S DATA=$G(^PSD(58.811,PSAIEN,1,PSAIEN1,0))
  S PSALOC=$S($P(DATA,"^",12)'="":$P(DATA,"^",12),1:$P(DATA,"^",5)) I $G(PSALOC)="" S PSALOC="No Location identified"
  D ^PSAVERA1
+ ;
  K DATA,PSAITM,LINENUM,X,X1,X2,X3,DIC,DA,DR D HDR
 DISP S PSAITM=$S('$D(PSAITM):$O(INVARRAY(PSAORD,PSAINV,0)),1:$O(INVARRAY(PSAORD,PSAINV,PSAITM))) G LINEASK:PSAITM'>0 S LINENUM=$G(LINENUM)+1
- S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM)),PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit  ;; <*63 RJS
- W !,PSAITM,?10,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5)  ;; *63 RJS>
+ S DATA=$G(INVARRAY(PSAORD,PSAINV,PSAITM))
+ S PSAOU=$P(DATA,"^",4) I $G(PSAOU) S PSAOU(1)=$P($G(^DIC(51.5,$P(DATA,"^",4),0)),"^") ;Current Order Unit
+ W !,PSAITM,?10,$S($P($P(DATA,"^",1),"~",1)'>0:$P($P(DATA,"^",1),"~",1),1:$P($P(DATA,"^",1),"~",2)),?45,$S($G(PSAOU)="":"none",$G(PSAOU(1))'="":$G(PSAOU(1)),1:$G(PSAAOU)),?55,$J($P($G(DATA),"^",2),4),?61,$P(DATA,"^",5)
  I IOST["C-",$Y>(IOSL-5) S DIR(0)="E" D ^DIR G Q:$G(DUOUT)=1 D HDR
  G DISP
@@ -31,23 +34,23 @@
  S PSALINEN="" D VERDISP^PSAUTL4 W !,PSASLN,!
  S PSAVEND=$P(^PSD(58.811,PSAIEN,0),"^",2)
+ ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;GET ORIGINAL DISPENSE UNITS PER ORDER UNIT FOR SUBTRACTION
  S PSAODUOU=PSADUOU
- ;; *63
- S PSA581="" F  S PSA581=$O(^PSD(58.81,"PV",PSAINV,PSA581)) Q:'PSA581  I $P(^PSD(58.81,PSA581,0),U,5)=PSADRG S PSABFR(581)=$G(^PSD(58.81,PSA581,0))
- S:$G(PSABFR(581)) PSDTRN=$P(PSABFR(581),U,1),PSABFR("Q")=$S($G(^PSD(58.81,PSDTRN,4)):$P(^PSD(58.81,PSDTRN,4),"^",3),1:$P(^PSD(58.81,PSDTRN,0),"^",6)) ; <*63 RJS >
+ ;
 DRG W !,"Select (D)rug or (O)rder Unit " R AN:DTIME G Q:AN["^"!(AN="") W $S("Dd"[AN:"rug","oO"[AN:"rder Unit",1:"??") I "DdOo"'[AN W !,"Enter a 'D' to edit the Drug, or 'O' to edit the order unit",! K AN G DRG
- I "Dd"'[AN D ^PSAVERA3 G Q  ;;*63
+ I "Dd"'[AN G ^PSAVERA3
  ;Get either new name of drug or supply item description
- S PSABFR=$P(DATA,"~",1),PSABFR(1)=$S(PSABFR'?.N:PSABFR,1:$P($P(DATA,"^"),"~",2)),PSABFR("NDC")=$P(PSADATA,"^",11)  ;;*63
+ S PSABEFOR=$P(DATA,"~",1),PSABEFOR(1)=$S(PSABEFOR'?.N:PSABEFOR,1:$P($P(DATA,"^"),"~",2))
+ S PSABEFOR("NDC")=$P(PSADATA,"^",11)
 DRGAGN D
- .S X1=0 F  S X1=$O(^PSDRUG(PSABFR,1,X1)) Q:X1'>0  S DATA=$G(^PSDRUG(PSABFR,1,X1,0)) I $P(DATA,"^",2)=PSABFR("NDC") S PSABFR("SYNNODE")=X1  ;;*63
+ .S X1=0 F  S X1=$O(^PSDRUG(PSABEFOR,1,X1)) Q:X1'>0  S DATA=$G(^PSDRUG(PSABEFOR,1,X1,0)) I $P(DATA,"^",2)=PSABEFOR("NDC") S PSABEFOR("SYNNODE")=X1
  D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
- I $G(PSABFR("SYNNODE"))="",$E(PSABFR("NDC"))'="S" S PSABFR("NDC")="S"_PSABFR("NDC") G DRGAGN ;may be supply, try again
- I $G(PSABFR("SYNNODE"))'="" S PSASUB=PSABFR("SYNNODE") D
- .S DATA=$G(^PSDRUG(PSABFR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8)
- .S PSADU=$P($G(^PSDRUG(PSABFR,660)),"^",8)
+ I $G(PSABEFOR("SYNNODE"))="",$E(PSABEFOR("NDC"))'="S" S PSABEFOR("NDC")="S"_PSABEFOR("NDC") G DRGAGN ;may be supply, try again
+ I $G(PSABEFOR("SYNNODE"))'="" S PSASUB=PSABEFOR("SYNNODE") D
+ .S DATA=$G(^PSDRUG(PSABEFOR,1,PSASUB,0)),PSAOU=$P(DATA,"^",5),PSAPOU=$P(DATA,"^",6),PSADUOU=$P(DATA,"^",7),PSAPDUOU=$P(DATA,"^",8)
+ .S PSADU=$P($G(^PSDRUG(PSABEFOR,660)),"^",8)
  I ($G(PSAOU)=""!$G(PSAPOU)=""!$G(PSADUOU)=""!$G(PSAPDUOU)="") W !!,"Sorry, I could not find the necessary information to change the drug selection.",! G Q
- W !,"Current Drug : ",PSABFR(1)
-DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABFR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT
- I $G(DTOUT)!($G(DUOT))!(Y<0) S PSAOUT=1 Q
+ W !,"Current Drug : ",PSABEFOR(1)
+DRG1 S PSAGAIN=0,DIC("A")="Select name of Correct Drug: ",PSABEFOR=PSADRG,DIC(0)="AEQMZ",DIC="^PSDRUG(" D ^DIC K DIC G Q:PSAOUT
+ I $G(DTOUT)!($G(DUOT)) S PSAOUT=1 Q
  S (PSADJ,PSADRG)=+Y
  W !!,"Comparing drug file data..."
@@ -55,4 +58,5 @@
  I $P($G(^PSDRUG(PSADRG,660)),"^",2)'=$G(PSAOU) W !,"The Order Units are different between these two drugs."
  I $P($G(^PSDRUG(PSADRG,660)),"^",8)'=$G(PSADU) W !,"Please Enter an appropriate Dispense Unit" S DIE="^PSDRUG(",DA=PSADRG,DR="14.5" D ^DIE S PSADU=$P(^PSDRUG(PSADRG,660),"^",8)
+ ;VMP OIFO BAY PINES;VGF;PSA*3.0*36
  I $P($G(^PSDRUG(PSADRG,660)),"^",5)'=$G(PSADUOU) W !,"Please enter the appropriate Dispense Units per order unit" S DIE="^PSDRUG(",DA=PSADRG,DR="15" D ^DIE S PSADUOU=$P(^PSDRUG(PSADRG,660),"^",5)
  K DIE,DA,DR
@@ -60,25 +64,73 @@
  S AN=$E(AN) I "yYnN"'[AN W !,"Answer yes, and the data on file for the current drug will be transferred",!,"to the new drug selection.",!,"That includes Order Unit, Dispense Unit, Dispense Units per Order Unit, etc.",!! G ASK
  I "Nn"[AN G NOCHNG ;*53
- S PSAAFTER=PSADRG,PSADRG=PSABFR
- I $D(^PSDRUG(PSADRG))&$G(PSABFR(581)) D
- .W !,"Removing "_PSABFR("Q")_" from "_PSABFR(1)
- .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-PSABFR("Q"),DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA
- .F  L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- .D ^DIE L -^PSDRUG(DA,0) K FMDATA
+ ;VMP OIFO BAY PINES;VGF;PSA*3.0*36
+ S PSAAFTER=PSADRG,PSADRG=PSABEFOR
+ I $D(^PSDRUG(PSADRG)) D
+ .;VMP OIFO BAY PINES;VGF;PSA*3.0*40
+ .W !,"Removing "_($G(PSAQTY)*$G(PSAODUOU))_" from "_PSABEFOR(1)
+ .S FMDATA=$P($G(^PSDRUG(PSADRG,660.1)),"^")-(PSAODUOU*PSAQTY)
+ .S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_FMDATA
+ .F  L +^PSDRUG(DA,0):0 I  Q
+ .D ^DIE
+ .L -^PSDRUG(DA,0)
+ .K FMDATA
  S PSADRG=PSAAFTER
  I $G(PSAPOU)="",$G(PSAPRICE)'="" S PSAPOU=PSAPRICE
  W !,"Adding "_($G(PSAQTY)*$G(PSADUOU))_" to "_$P($G(^PSDRUG(PSADRG,0)),"^")
  W !,"Entering new drug selection as an adjustment."
- S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2,50^PSAVER7
+ S PSAREA="",PSADJFLD="D",PSADJ=PSADRG D RECORD^PSAVER2
+ D 50^PSAVER7
 FILE ;File dispense units per order units into 58.811
- S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,",DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN,DR="10///"_PSADUOU D ^DIE
- G:$D(^PSD(58.811,"ASTAT","P",PSAIEN,PSAIEN1)) Q  ;; *63 RJS
- D UPDATE^PSAVERA1 G Q
+ S DIE="^PSD(58.811,"_PSAIEN_",1,"_PSAIEN1_",1,"
+ S DA=PSALINE,DA(1)=PSAIEN1,DA(2)=PSAIEN
+ S DR="10///"_PSADUOU
+ D ^DIE
+ ;File data in 58.8
+ ;PSALOC= Either PSALOC or PSALOCB
+ ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;UPDATE 
+ S PSADRG=PSABEFOR
+ F  L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I  Q
+ S PSADUREC=PSAQTY*$G(PSAODUOU)
+ S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
+ S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-PSADUREC
+ L -^PSD(58.8,PSALOC,1,PSADRG,0)
+ ;VMP OIFO BAY PINES;VGF;PSA*3.0*40;ADDED *$G(PSADUOU)
+ S PSADRG=PSAAFTER
+ S PSADUREC=PSAQTY*$G(PSADUOU)
+ D NOW^%DTC S PSADT=+$E(%,1,14)
+ I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
+ .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
+ .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53
+ .F  L +^PSD(58.8,PSALOC,0):0 I  Q
+ .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
+ F  L +^PSD(58.8,PSALOC,1,PSADRG,0):0 I  Q
+ S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
+ I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
+ S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
+ I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
+ .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
+ .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
+ S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
+ I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
+ .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC
+ .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y
+ .S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
+ S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE
+ L -^PSD(58.8,PSALOC,1,PSADRG,0)
+ W !,"updating pharmacy location file."
+FILE581 ;Update transaction file
+ S PSAVDUZ=DUZ
+FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
+ S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0)
+ S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD"
+ I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS"
+ F  L +^PSD(58.81,DA,0):0 I  Q
+ D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q
  ;
 HDR W @IOF,!?25,"EDIT VERIFIED INVOICED ITEM SCREEN",!,PSASLN,!
  W !,?44,"Order",!,"#",?10,"Drug/Item Name",?45,"Unit",?56,"Qnty.",?67,"NDC",!,PSASLN,! Q
-Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,POP,PSA50IEN,PSA581,PSAABAL,PSAAFTER,PSAAQTY,PSABAL,PSABFR,PSACS,PSADASH,PSADATA,PSADJ,PSADJD,PSADJFLD,PSADJO,PSADJP,PSADJQ,PSADRG,PSADRUGN,PSADT
- K PSADU,PSADUOU,PSADUREC,PSAEDTT,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSAITM,PSALINE,PSALINEN,PSALOC,PSANDC,PSANDUOU,PSANEW,PSANODE,PSANPDU,PSANQTY,PSAODASH,PSAODU,PSAODUOU,PSAONDC,PSAORD
- K PSAOU,PSAOUT,PSAPOU,PSAPRICE,PSAQTY,PSAREA,PSAREORD,PSASET,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSATEMP,PSAUPC,PSAVDUZ,PSAVEND,PSAVER,PSAVSN,PSAXDUOU,PSDTRN,X,X1,X2,X3,XX,XXX,Y
+Q K AN,D,DA,DATA,DIC,DIR,INVARRAY,LINENUM,PSA50IEN,PSABAL,PSABEFOR,PSACS,PSADATA,PSADJ,PSADJFLD,PSADRG,PSADT,PSADUREC,PSAGAIN,PSAIEN,PSAIEN1,PSAIN,PSAINV,PSALINE,PSALINEN
+ K PSALOC,PSANDC,PSAORD,PSAOUT,PSAQTY,PSAREA,PSAREORD,PSASLN,PSASTOCK,PSASUB,PSASUP,PSASUPP,PSAT,PSAVER,X,X1,X2,X3,XX,XXX,Y,PSAODUOU
+ K PSAODU,PSAODUOU,PSAXDUOU
  Q
 NOCHNG ;*53 said no to changes, backout the edits on the new drug choice.
Index: FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m
===================================================================
--- FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m	(revision 631)
+++ FOIAVistA/tag/r/DRUG_ACCOUNTABILITY-PSA/PSAVERA1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSAVERA1 ;BHM/DB - Edit previously verified invoices;16NOV99
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61,63**; 10/24/97;Build 10
+ ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,61**; 10/24/97;Build 1
  ;References to ^DIC(51.5 are covered by IA #1931
  ;References to ^PSDRUG( are covered by IA #2095
@@ -81,56 +81,2 @@
  .I PSAFLD=2 D OU^PSAVER2 Q
 Q Q
- ;
-UPDATE ; *63 RJS CODE REMOVED FROM PSAVERA AND CALLED BY PSAVERA
- ;File data in 58.8
- ;PSALOC= Either PSALOC or PSALOCB
- S PSADRG=PSABFR
- F  L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- S PSADUREC=PSAQTY*$G(PSAODUOU),PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4),$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSABAL-$G(PSABFR("Q"))
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- S PSADRG=PSAAFTER,PSAABAL=PSABAL,PSADUREC=PSAQTY*$G(PSADUOU)
- D NOW^%DTC S PSADT=+$E(%,1,14)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
- .S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
- .S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,DINUM,X)=PSADRG,DIC(0)="L",DLAYGO=58.8 ;*53
- .F  L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- .D FILE^DICN L -^PSD(58.8,PSALOC,0) K DIC,DA,DLAYGO
- F  L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- S PSABAL=$P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4)
- I $P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",1)'=PSADRG S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",1)=PSADRG
- S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSADUREC+PSABAL
- I +$P($G(^PSD(58.8,PSALOC,0)),"^",14) D
- .I PSASTOCK'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",3)=PSASTOCK
- .I PSAREORD'=$P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5) S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",5)=PSAREORD
- S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
- I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
- .S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSABAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC
- .S X="T-1M" D ^%DT S DIC="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100 D ^DIC K DIC,DLAYGO S DA=+Y
- .S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DR="3////^S X=$G(PSABAL)" D ^DIE K DIE
- S DA(2)=PSALOC,DA(1)=PSADRG,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",5,",DA=$E(DT,1,5)*100,DR="5////^S X="_($P($G(^(0)),"^",3)+PSADUREC) D ^DIE K DIE
- L -^PSD(58.8,PSALOC,1,PSADRG,0)
- W !,"updating pharmacy location file."
-FILE581 ;Update transaction file ;;*63
- S PSAVDUZ=DUZ,PSAREA="EDIT VERIFIED INVOICE"
- I '$G(PSABFR(581)) D NEW581 Q
- I PSADRG'=PSABFR S PSANQTY=0,PSAAQTY=$G(PSABFR("Q"))*-1
- I PSADRG=PSABFR S PSANQTY=PSADUREC D
- .S PSAAQTY=PSADUREC-$G(PSABFR("Q"))
-FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
- S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0)
- S DIE="^PSD(58.81,",DA=PSAT
- I PSAAFTER'=PSABFR S PSADRG=PSABFR
- S DR="1////14;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;48////^S X=PSADT;49////^S X=PSAVDUZ;50////^S X=PSANQTY;51////^S X=PSAAQTY;53////^S X=PSAREA;54////^S X=PSAABAL;71////^S X=PSAINV;106////^S X=PSAORD"
- F  L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE
- I PSAAFTER'=PSABFR S PSADRG=PSAAFTER D NEW581
- Q
- ;
-NEW581 S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G NEW581
- S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO L -^PSD(58.81,0)
- S PSADUREC=PSAQTY*$G(PSADUOU)
- S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSADUREC;6////^S X=PSAVDUZ;9////^S X=PSABAL;71////^S X=PSAINV;106////^S X=PSAORD"
- I $G(PSACS)>0 S DR=DR_";100////^S X=PSACS"
- F  L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I  Q
- D ^DIE L -^PSD(58.81,DA,0) K DIE W !,"updating transaction file." Q
- Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX802.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX802.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX802.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 02/03/08
+ECX802 ; DRIVER FOR COMPILED XREFS FOR FILE #727.802 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8021.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8021.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8021.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 02/03/08
+ECX8021 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8022.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8022.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8022.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 02/03/08
+ECX8022 ; COMPILED XREF FOR FILE #727.802 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX804.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX804.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX804.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX804 ; DRIVER FOR COMPILED XREFS FOR FILE #727.804 ; 10/15/04
+ECX804 ; DRIVER FOR COMPILED XREFS FOR FILE #727.804 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8041.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8041.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8041.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8041 ; COMPILED XREF FOR FILE #727.804 ; 10/15/04
+ECX8041 ; COMPILED XREF FOR FILE #727.804 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8042.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8042.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8042.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8042 ; COMPILED XREF FOR FILE #727.804 ; 10/15/04
+ECX8042 ; COMPILED XREF FOR FILE #727.804 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX805.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX805.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX805.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX805 ; DRIVER FOR COMPILED XREFS FOR FILE #727.805 ; 12/12/07
+ECX805 ; DRIVER FOR COMPILED XREFS FOR FILE #727.805 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8051.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8051.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8051.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8051 ; COMPILED XREF FOR FILE #727.805 ; 12/12/07
+ECX8051 ; COMPILED XREF FOR FILE #727.805 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8052.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8052.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8052.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8052 ; COMPILED XREF FOR FILE #727.805 ; 12/12/07
+ECX8052 ; COMPILED XREF FOR FILE #727.805 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX806.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX806.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX806.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX806 ; DRIVER FOR COMPILED XREFS FOR FILE #727.806 ; 10/15/04
+ECX806 ; DRIVER FOR COMPILED XREFS FOR FILE #727.806 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8061.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8061.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8061.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8061 ; COMPILED XREF FOR FILE #727.806 ; 10/15/04
+ECX8061 ; COMPILED XREF FOR FILE #727.806 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8062.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8062.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8062.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8062 ; COMPILED XREF FOR FILE #727.806 ; 10/15/04
+ECX8062 ; COMPILED XREF FOR FILE #727.806 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX808.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX808.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX808.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 02/03/08
+ECX808 ; DRIVER FOR COMPILED XREFS FOR FILE #727.808 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8081.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8081.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8081.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 02/03/08
+ECX8081 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8082.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8082.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8082.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 02/03/08
+ECX8082 ; COMPILED XREF FOR FILE #727.808 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX809.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX809.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX809.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 02/03/08
+ECX809 ; DRIVER FOR COMPILED XREFS FOR FILE #727.809 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8091.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8091.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8091.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 02/03/08
+ECX8091 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8092.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8092.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8092.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 02/03/08
+ECX8092 ; COMPILED XREF FOR FILE #727.809 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX810.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX810.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX810.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 02/03/08
+ECX810 ; DRIVER FOR COMPILED XREFS FOR FILE #727.81 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8101.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8101.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8101.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 02/03/08
+ECX8101 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8102.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8102.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8102.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 02/03/08
+ECX8102 ; COMPILED XREF FOR FILE #727.81 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX811.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX811.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX811.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 02/03/08
+ECX811 ; DRIVER FOR COMPILED XREFS FOR FILE #727.811 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8111.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8111.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8111.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 02/03/08
+ECX8111 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8112.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8112.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8112.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 02/03/08
+ECX8112 ; COMPILED XREF FOR FILE #727.811 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX813.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX813.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX813.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 02/03/08
+ECX813 ; DRIVER FOR COMPILED XREFS FOR FILE #727.813 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8131.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8131.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8131.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 02/03/08
+ECX8131 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8132.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8132.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8132.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 02/03/08
+ECX8132 ; COMPILED XREF FOR FILE #727.813 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX814.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX814.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX814.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 02/03/08
+ECX814 ; DRIVER FOR COMPILED XREFS FOR FILE #727.814 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8141.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8141.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8141.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 02/03/08
+ECX8141 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8142.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8142.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8142.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 02/03/08
+ECX8142 ; COMPILED XREF FOR FILE #727.814 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX815.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX815.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX815.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 02/03/08
+ECX815 ; DRIVER FOR COMPILED XREFS FOR FILE #727.815 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8151.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8151.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8151.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 02/03/08
+ECX8151 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8152.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8152.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8152.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 02/03/08
+ECX8152 ; COMPILED XREF FOR FILE #727.815 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX817.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX817.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX817.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 02/03/08
+ECX817 ; DRIVER FOR COMPILED XREFS FOR FILE #727.817 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8171.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8171.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8171.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 02/03/08
+ECX8171 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8172.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8172.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8172.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 02/03/08
+ECX8172 ; COMPILED XREF FOR FILE #727.817 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX819.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX819.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX819.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 02/03/08
+ECX819 ; DRIVER FOR COMPILED XREFS FOR FILE #727.819 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8191.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8191.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8191.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 02/03/08
+ECX8191 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8192.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8192.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8192.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 02/03/08
+ECX8192 ; COMPILED XREF FOR FILE #727.819 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX820.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX820.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX820.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX820 ; DRIVER FOR COMPILED XREFS FOR FILE #727.82 ; 10/15/04
+ECX820 ; DRIVER FOR COMPILED XREFS FOR FILE #727.82 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8201.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8201.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8201.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8201 ; COMPILED XREF FOR FILE #727.82 ; 10/15/04
+ECX8201 ; COMPILED XREF FOR FILE #727.82 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8202.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8202.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8202.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8202 ; COMPILED XREF FOR FILE #727.82 ; 10/15/04
+ECX8202 ; COMPILED XREF FOR FILE #727.82 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX821.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX821.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX821.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX821 ; DRIVER FOR COMPILED XREFS FOR FILE #727.821 ; 10/15/04
+ECX821 ; DRIVER FOR COMPILED XREFS FOR FILE #727.821 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8211.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8211.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8211.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8211 ; COMPILED XREF FOR FILE #727.821 ; 10/15/04
+ECX8211 ; COMPILED XREF FOR FILE #727.821 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8212.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8212.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8212.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8212 ; COMPILED XREF FOR FILE #727.821 ; 10/15/04
+ECX8212 ; COMPILED XREF FOR FILE #727.821 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX822.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX822.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX822.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX822 ; DRIVER FOR COMPILED XREFS FOR FILE #727.822 ; 10/15/04
+ECX822 ; DRIVER FOR COMPILED XREFS FOR FILE #727.822 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8221.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8221.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8221.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8221 ; COMPILED XREF FOR FILE #727.822 ; 10/15/04
+ECX8221 ; COMPILED XREF FOR FILE #727.822 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8222.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8222.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8222.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8222 ; COMPILED XREF FOR FILE #727.822 ; 10/15/04
+ECX8222 ; COMPILED XREF FOR FILE #727.822 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX823.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX823.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX823.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX823 ; DRIVER FOR COMPILED XREFS FOR FILE #727.823 ; 10/15/04
+ECX823 ; DRIVER FOR COMPILED XREFS FOR FILE #727.823 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8231.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8231.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8231.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8231 ; COMPILED XREF FOR FILE #727.823 ; 10/15/04
+ECX8231 ; COMPILED XREF FOR FILE #727.823 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8232.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8232.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8232.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8232 ; COMPILED XREF FOR FILE #727.823 ; 10/15/04
+ECX8232 ; COMPILED XREF FOR FILE #727.823 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX824.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX824.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX824.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 02/03/08
+ECX824 ; DRIVER FOR COMPILED XREFS FOR FILE #727.824 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8241.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8241.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8241.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 02/03/08
+ECX8241 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8242.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8242.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8242.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 02/03/08
+ECX8242 ; COMPILED XREF FOR FILE #727.824 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX825.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX825.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX825.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 02/03/08
+ECX825 ; DRIVER FOR COMPILED XREFS FOR FILE #727.825 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8251.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8251.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8251.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 02/03/08
+ECX8251 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8252.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8252.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8252.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 02/03/08
+ECX8252 ; COMPILED XREF FOR FILE #727.825 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX826.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX826.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX826.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 02/03/08
+ECX826 ; DRIVER FOR COMPILED XREFS FOR FILE #727.826 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8261.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8261.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8261.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 02/03/08
+ECX8261 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8262.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8262.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8262.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 02/03/08
+ECX8262 ; COMPILED XREF FOR FILE #727.826 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX827.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX827.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX827.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 02/03/08
+ECX827 ; DRIVER FOR COMPILED XREFS FOR FILE #727.827 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8271.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8271.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8271.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 02/03/08
+ECX8271 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8272.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8272.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8272.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 02/03/08
+ECX8272 ; COMPILED XREF FOR FILE #727.827 ; 12/27/07
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8904.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX8904.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX8904.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX8904 ; DRIVER FOR COMPILED XREFS FOR FILE #728.904 ; 12/02/05
+ECX8904 ; DRIVER FOR COMPILED XREFS FOR FILE #728.904 ; 04/10/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX89041.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX89041.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX89041.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX89041 ; COMPILED XREF FOR FILE #728.904 ; 12/02/05
+ECX89041 ; COMPILED XREF FOR FILE #728.904 ; 04/10/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX89042.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECX89042.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECX89042.m	(revision 636)
@@ -1,3 +1,3 @@
-ECX89042 ; COMPILED XREF FOR FILE #728.904 ; 12/02/05
+ECX89042 ; COMPILED XREF FOR FILE #728.904 ; 04/10/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXADM.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXADM.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXADM.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 10/15/07 12:14pm
- ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107,105**;Dec 22, 1997;Build 70
+ECXADM ;ALB/JAP,BIR/DMA,CML,PTD-Admissions Extract ; 04/12/2007
+ ;;3.0;DSS EXTRACTS;**1,4,11,8,13,24,33,39,46,71,84,92,107**;Dec 22, 1997;Build 9
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -46,11 +46,4 @@
  S ECXPRV=$P(ADM,U,7),ECXPRNPI="",ECXATT=$P(ADM,U,8),ECXATNPI=""
  S ECXDOM=$P(ADM,U,10),ECXATTPC=$P(ADM,U,12),ECXPRVPC=$P(ADM,U,11)
- N ECXUSRTN
- S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXATT,2,$L(ECXATT)),ECD)
- S:+ECXUSRTN'>0 ECXUSRTN=""
- S ECATTNPI=$P(ECXUSRTN,U)
- S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$E(ECXPRV,2,$L(ECXPRV)),ECD)
- S:+ECXUSRTN'>0 ECXUSRTN=""
- S ECPWNPI=$P(ECXUSRTN,U)
  ;
  ;- Observation patient indicator (YES/NO)
@@ -98,8 +91,4 @@
  S ECXHI=+$$INSUR^IBBAPI(ECXDFN,ECXDATE)
  S ECXEST=ECXPAT("EC STAT")
- ;
- ;-OEF/OIF Data
- S ECXOEF=ECXPAT("ECXOEF")
- S ECXOEFDT=ECXPAT("ECXOEFDT")
  ;
  ;- Agent Orange location
@@ -156,7 +145,5 @@
  ;^emergency response indicator(FEMA) ECXERI^agent orange indic ECXAO
  ;^environ contam ECXECE^encoun head/neck ECXHNC^encoun MST ECXMIL^rad
- ;encoun ECXIR^ OEF/OIF ECXOEF^ OEF/OIF return date ECXOEFDT
- ;^associate pc provider npi ECASNPI^attending physician npi ECATNPI^
- ;primary care provider npi ECPTNPI^primary ward provider npi ECPWNPI
+ ;encoun ECXIR
  ;
  ;Convert specialty to PTF Code
@@ -175,7 +162,7 @@
  S ECODE=ECODE_ECXWRD_U_ECXSPC_U_ECXATT_U_ECDA_U_ECDRG_U_ECDIA_U
  S ECODE=ECODE_ECTM_U_ECPTPR_U_ECXRACE_U_ECXPRV_U
- S ECODE1=ECXMPI_U_ECXDSSD_U_""_U_""_U_""_U_ELGA_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXATNPI_U_ECPTNPI_U_ECXPRNPI_U_ELGA_U
  S ECODE1=ECODE1_ECXMST_U_U_U_U_ECXENRL_U_ECCLAS_U
- S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U
+ S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U
  S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
  S ECODE1=ECODE1_ECXPDIV_U_ECXPLOC_U_ECXSADM_U_ECXHNCI_U_ECXETH_U
@@ -183,7 +170,6 @@
  I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
  I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATTPC_U_ECXPRVPC_U_ECXEST
- I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
- I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECATTNPI_U_ECPTNPI_U_ECPWNPI
- S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2)
+ I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
  S ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXAPHA2.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXAPHA2.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXAPHA2.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 10/18/07 2:10pm
- ;;3.0;DSS EXTRACTS;**40,49,84,104,105**;Dec 22, 1997;Build 70
+ECXAPHA2 ;ALB/TMD-Pharmacy Extracts Unusual Volumes Report ; 2/06/07 10:36am
+ ;;3.0;DSS EXTRACTS;**40,49,84,104**;Dec 22, 1997;Build 8
  ;
 EN ; entry point
@@ -12,37 +12,28 @@
  ;
 PRE ; entry point for PRE data
- N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC,IEN
- K ^TMP($J,"ECXDSS")
- ;call pharmacy api pso52ex
- D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
- S ECREF="RF"
- ;order thru fills and refills; refill values 0 thru 11
- ;     Note:  refill 0 = original fill
- F  S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL  Q:ECXERR  D PRE2
- ;
- ;order thru partial fills
+ ; order through fills, refills and partial refills
+ N ECRFL,ECRX,ECREF,ECDATA,ECDATA1,ECPRC
+ S ECREF=1
+ F  S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX  Q:ECXERR  F  S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL=""  Q:ECXERR  D PRE2
  S ECD=ECSD1,ECREF="P"
- F  S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL  Q:ECXERR  D PRE2
- K ^TMP($J,"ECXDSS")
+ F  S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL=""  Q:ECXERR  D PRE2
  Q
  ;
 PRE2 ; get Prescription data
- I (ECREF="RF")&(ECRFL) D
- .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1)
- .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.1)
- .S ECPRC=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1.2)
- I (ECREF="RF")&('ECRFL) D
- .S ECQTY=+^TMP($J,"ECXDSS",IEN,7)
- .S ECDS=+^TMP($J,"ECXDSS",IEN,8)
- .S ECPRC=+^TMP($J,"ECXDSS",IEN,17)
- I ECREF="P" D
- .S ECQTY=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04)
- .S ECDS=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.041)
- .S ECPRC=+^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.042)
+ S ECDATA=$G(^PSRX(ECRX,0))
+ I ECRFL D
+ .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0))
+ .S ECQTY=+$P(ECDATA1,U,4)
+ .S ECDS=+$P(ECDATA1,U,10)
+ .S ECPRC=+$P(ECDATA1,U,11)
+ I 'ECRFL D
+ .S ECQTY=+$P(ECDATA,U,7)
+ .S ECDS=+$P(ECDATA,U,8)
+ .S ECPRC=+$P(ECDATA,U,17)
  ;check to see if quantity>threshold
  I ECQTY>ECTHLD D
  .S ECDAY=ECD
- .S ECDFN=$P(^TMP($J,"ECXDSS",IEN,2),U)
- .S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
+ .S ECDFN=$P(ECDATA,U,2)
+ .S ECDRG=+$P(ECDATA,U,6)
  .S ECCOST=ECQTY*ECPRC
  .D FILE Q:ECXERR
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXATRT.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXATRT.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXATRT.m	(revision 636)
@@ -1,4 +1,4 @@
 ECXATRT ;ALB/JAP - TRT Extract Audit Report ;O4/12/2007
- ;;3.0;DSS EXTRACTS;**1,6,8,107,105**;Dec 22, 1997;Build 70
+ ;;3.0;DSS EXTRACTS;**1,6,8,107**;Dec 22, 1997;Build 9
  ;
 EN ;entry point for TRT extract audit report
@@ -87,9 +87,9 @@
  ..;
  ..N ECXTS
- ..S ECXTS=$P(DATA,U,15) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,15)=ECXTS
- ..S ECXTS=$P(DATA,U,16) I ECXTS'="" S ECXTS=$O(^DIC(42.4,"C",$G(ECXTS),0)),$P(DATA,U,16)=ECXTS
+ ..S ECXTS=$P(DATA,U,15),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,15),0)),$P(DATA,U,15)=ECXTS
+ ..S ECXTS=$P(DATA,U,16),ECXTS=$O(^DIC(42.4,$G(ECXTS),"C",$P(DATA,U,16),0)),$P(DATA,U,16)=ECXTS
  ..S NEWTS=$P(DATA,U,15),TS=$P(DATA,U,16),LOS=$P(DATA,U,17)
  ..;leaving this next line in here for v3.0 extracts done prior to patch #1
- ..Q:(NUM(+TS)=1)&(NEWTS=TS)
+ ..Q:(NUM(TS)=1)&(NEWTS=TS)
  ..Q:LOS=""
  ..S $P(^(TS),U,1)=$P(^TMP($J,"ECXSPEC",DIV,TS),U,1)+1,CNT=CNT+1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDIVIV.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXDIVIV.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDIVIV.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; 3/13/07 10:48am
- ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
+ECXDIVIV ;BIR/CML-Enter/Edit and Print IV Room Division ; [ 11/15/96  11:12 AM ]
+ ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
  ;
 ED ;enter/edit division field for iv rooms
@@ -25,5 +25,4 @@
  .W !,"NO DEVICE SELECTED OR REPORT PRINTED!!"
  .D PAUSE
- K ^TMP($J,"ECXDSS")
  Q
  ;
@@ -31,11 +30,9 @@
  N CHKFLG,DIV,DIVNM,INACT,IV,IVRM,JJ,LN1,LN2,PDT,PG,QFLG,SS,X,Y
  I '$D(DT) S DT=$$HTFM^XLFDT(+$H)
- K ^TMP("ECXDIVIV",$J),^TMP($J,"ECXDSS") S QFLG=0,IV=0
- ;call pharmacy encapsulation api and return all iv rooms information
- D ALL^PSJ59P5(,"??","ECXDSS")
- F  S IV=$O(^TMP($J,"ECXDSS",IV)) Q:'IV  D
- .S IVRM=$G(^TMP($J,"ECXDSS",IV,.01)),DIV=$P($G(^(.02)),U)
+ K ^TMP("ECXDIVIV",$J) S QFLG=0,IV=0
+ F  S IV=$O(^PS(59.5,IV)) Q:'IV  I $D(^PS(59.5,IV,0)) D
+ .S IVRM=$E($P(^PS(59.5,IV,0),U),1,30),DIV=$P(^(0),U,4)
  .S DIVNM=$S(DIV="":"ZZZ",1:$E($P(^DG(40.8,DIV,0),U),1,30))
- .K INACT I $P($G(^TMP($J,"ECXDSS",IV,19)),U)]"" S INACT=$P(^(19),U,2)
+ .K INACT I $P($G(^PS(59.5,IV,"I")),U)]"" S INACT=$$FMTE^XLFDT($P(^PS(59.5,IV,"I"),U),1)
  .S ^TMP("ECXDIVIV",$J,DIVNM,IVRM)=$S($D(INACT):INACT,1:"")
  ;print report
@@ -67,17 +64,16 @@
 CHK ;check for existence of necessary files for division functionality
  S CHKFLG=0
- D ALL^PSJ59P5(,"??","ECXIV")
- I '$O(^TMP($J,"ECXIV",0)) D  I CHKFLG D EXIT Q
+ I '$O(^PS(59.5,0)) D  Q:CHKFLG
  .W !,"The IV Room file (#59.5) does not exist!"
  .S CHKFLG=1 D PAUSE
- I '$D(^ECX(728.113,0)) D  I CHKFLG D EXIT Q
+ I '$D(^ECX(728.113,0)) D  Q:CHKFLG
  .W $C(7),!!,"Your facility appears to be running a version of Inpatient Medications prior to"
  .W !,"version 4.5 which is necessary to use this option."
  .S CHKFLG=1 D PAUSE
- I '$D(^TMP($J,"ECXIV",$O(^TMP($J,"ECXIV",0)),.02)) D
+ K TEST1 D FIELD^DID(59.5,.02,"","TYPE","TEST1")
+ I '$D(TEST1) D
  .W $C(7),!!,"The Inpatient Medications Patch PSJ*4.5*27 has not yet been installed!"
  .W !,"It must be loaded before you can proceed with this option."
  .S CHKFLG=1 D PAUSE
-EXIT K ^TMP($J,"ECXIV")
  Q
  ;
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDRUG2.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXDRUG2.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDRUG2.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 2/19/08 3:44pm
- ;;3.0;DSS EXTRACTS;**40,68,84,105,111**;Dec 22, 1997;Build 4
+ECXDRUG2 ;ALB/TMD-Pharmacy Extracts Incomplete Feeder Key Report ; 6/13/05 3:31pm
+ ;;3.0;DSS EXTRACTS;**40,68,84**;Dec 22, 1997
  ;
 EN ; entry point
@@ -13,25 +13,17 @@
  ; order through fills, refills and partial refills
  N ECRFL,ECRX,ECREF,ECDATA,ECDATA1
- K ^TMP($J,"ECXDSS")
- ;call pharmacy api pso52ex
- D EXTRACT^PSO52EX(ECD,ECED,"ECXDSS")
- S ECREF="RF"
- ;order thru fills and refills; refill values 0 thru 11
- ;     Note:  refill 0 = original fill
- F  S ECD=$O(^TMP($J,"ECXDSS","AL",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:ECRFL']""  Q:ECXERR  D PRE2
- ;
- ;order thru partial fills
+ S ECREF=1
+ F  S ECD=$O(^PSRX("AL",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED   Q:ECXERR  F  S ECRX=$O(^PSRX("AL",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AL",ECD,ECRX,ECRFL)) Q:ECRFL=""  Q:ECXERR  D PRE2
  S ECD=ECSD1,ECREF="P"
- F  S ECD=$O(^TMP($J,"ECXDSS","AM",ECD)),IEN=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S IEN=$O(^(ECD,IEN)),ECRFL=""  Q:'IEN  Q:ECXERR  F  S ECRFL=$O(^(IEN,ECRFL)) Q:'ECRFL  Q:ECXERR  D PRE2
- K ^TMP($J,"ECXDSS")
+ F  S ECD=$O(^PSRX("AM",ECD)),ECRX=0 Q:'ECD  Q:ECD>ECED  Q:ECXERR  F  S ECRX=$O(^PSRX("AM",ECD,ECRX)),ECRFL="" Q:'ECRX  F  S ECRFL=$O(^PSRX("AM",ECD,ECRX,ECRFL)) Q:ECRFL=""  D PRE2
  Q
  ;
 PRE2 ; get Prescription data
- S ECDRG=+$P(^TMP($J,"ECXDSS",IEN,6),U)
- I ECRFL>0&(ECREF="RF") D
- .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,1),ECPRC=^(1.2)
- I ECRFL>0&(ECREF="P") D
- .S ECQTY=^TMP($J,"ECXDSS",IEN,ECREF,ECRFL,.04),ECPRC=^(.042)
- I 'ECRFL S ECQTY=^TMP($J,"ECXDSS",IEN,7),ECPRC=^(17)
+ S ECDATA=$G(^PSRX(ECRX,0))
+ S ECDRG=+$P(ECDATA,U,6)
+ I ECRFL D
+ .S ECDATA1=$G(^PSRX(ECRX,ECREF,ECRFL,0))
+ .S ECQTY=+$P(ECDATA1,U,4),ECPRC=+$P(ECDATA1,U,11)
+ I 'ECRFL S ECQTY=+$P(ECDATA,U,7),ECPRC=+$P(ECDATA,U,17)
  D TEST
  Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDVSN.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXDVSN.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDVSN.m	(revision 636)
@@ -1,4 +1,5 @@
-ECXDVSN ;ALB/JAP - Division selection utility ; 8/13/07 1:11pm
- ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
+ECXDVSN ;ALB/JAP - Division selection utility ;Sep 29, 1997
+ ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
+ ;
 ADM(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for ADM extract audit report
  ;selected inpatient divisions from medical center division file (#40.8)
@@ -23,4 +24,5 @@
  ;   ECXERR   = 1, if input problem occurs
  ;              0, otherwise
+ ;
  N OUT,DIC,X,Y,NM,ECXD,ECXIEN,ECXDIEN,ECXACT,ECXNAME,ECXNUM
  S (OUT,ECXERR)=0
@@ -53,4 +55,5 @@
  I '$D(ECXDIV) S ECXERR=1
  Q
+ ;
 ACTDIV(ECXIEN,ECXSTART,ECXEND,ECXD,ECXACT) ;determine if division active at anytime during date range
  ;to be called by ADM^ECXDVSN
@@ -78,4 +81,5 @@
  I DATE(ECXSTART)=-1,DATE(ECXEND)=-1 S ECXACT=0
  Q
+ ;
 MOV(ECXDIV,ECXALL,ECXSTART,ECXEND,ECXERR) ;division information for MOV extract audit report 
  ;selected divisions from medical center division file (#40.8)
@@ -84,6 +88,8 @@
  ;   output
  ;   (see ADM)
+ ;
  D ADM^ECXDVSN(.ECXDIV,ECXALL,ECXSTART,ECXEND,.ECXERR)
  Q
+ ;
 PAS(ECXDIV,ECXALL,ECXERR) ;setup division/site information for PAS extract audit report
  ;   input
@@ -94,6 +100,8 @@
  ;            ECXDIV(1)=ien in file #4^name^station number
  ;            where the INSTITUTION file pointer is obtained from file #728
+ ;
  S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
  Q
+ ;
 TRT(ECXDIV,ECXALL,ECXERR) ;setup division/site information for TRT extract audit report
  ;   input
@@ -104,6 +112,8 @@
  ;            ECXDIV(1)=ien in file #4^name^station number
  ;            where the INSTITUTION file pointer is obtained from file #728
+ ;
  S ECXALL=1 D DEFAULT^ECXDVSN(.ECXDIV,ECXALL,.ECXERR)
  Q
+ ;
 DEFAULT(ECXDIV,ECXALL,ECXERR) ;default division/site information for audit report
  ;   input
@@ -114,4 +124,5 @@
  ;            ECXDIV(1)=ien in file #4^name^station number
  ;            where the INSTITUTION file pointer is obtained from file #728
+ ;
  N DIV,ECX
  S ECXERR=0
@@ -123,4 +134,5 @@
  I '$D(ECXDIV) S ECXERR=1
  Q
+ ;
 DEN(ECXDIV,ECXALL,ECXERR) ;setup division/site information for DEN extract audit report
  ;   input
@@ -157,4 +169,5 @@
  I '$D(ECXDIV) S ECXERR=1
  Q
+ ;
 ECS(ECXDIV,ECXALL,ECXERR) ;setup division/location information for ECS extract audit report
  ;   input
@@ -206,23 +219,2 @@
  I '$D(ECXDIV) S ECXERR=1
  Q
-NUT() ; Set Divisions into screen array (prompt is one/many/all)
- ;Input  : SCRNARR - Screen array full global reference
- ;Output : 1 = OK     0 = User abort/timeout
- ;         @SCRNARR@("DIVISION") = User pick all divisions ?
- ;           1 = Yes (all)     0 = No
- ;         @SCRNARR@("DIVISION",PtrDiv) = Division name
- ;Note   : @SCRNARR@("DIVISION") is initialized (KILLed) on input
- ;       : @SCRNARR@("DIVISION",PtrDiv) is only set when the user
- ;         picked individual divisions (i.e. didn't pick all)
- ;
- ;Declare variables
- N VAUTD,Y,SCANARR
- ;Get division selection
- S DIC="^DIC(4,"
- S VAUTSTR="PATIENT DIVISION"
- S VAUTVB="SCANARR"
- S VAUTNI=2
- D FIRST^VAUTOMA
- I Y<0 Q 1
- M @SCRNARR@("DIVISION")=SCANARR
- Q 0
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDVSN1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXDVSN1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXDVSN1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ; 3/30/07 7:56am
- ;;3.0;DSS EXTRACTS;**8,105**;Dec 22, 1997;Build 70
+ECXDVSN1 ;ALB/JAP - Division selection utility (cont.) ;Sep 30, 1997
+ ;;3.0;DSS EXTRACTS;**8**;Dec 22, 1997
  ;
 ECQ(ECXDIV,ECXALL,ECXERR) ;setup division/site information for QSR extract audit report
@@ -134,24 +134,22 @@
  ;            if input problem, then '1' returned
  ;
- N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN,ARRAY
+ N X,Y,DIC,DIQ,DA,OUT,ECXARR,ECXP,ECXIEN
  S:'$D(ECXALL) ECXALL=1 S:ECXALL="" ECXALL=1
- S ECXERR=0,ECXP="",ARRAY="^TMP($J,""ECXDSS"")"
- K @ARRAY
+ S ECXERR=0,ECXP=""
  ;if ecxall=1, then all pharmacy sites are selected or there's only one
  I ECXALL=1 S ECXP="" D
- .D PSS^PSO59(,"??","ECXDSS")
- .F  S ECXP=$O(@ARRAY@("B",ECXP)) Q:ECXP=""  S ECXIEN=$O(^(ECXP,0)) Q:'ECXIEN  Q:'$D(^(ECXIEN))  D
- ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
+ .F  S ECXP=$O(^PS(59,"B",ECXP)) Q:ECXP=""  S ECXIEN=$O(^(ECXP,"")) D
+ ..K ECXARR S DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR",DA=ECXIEN D EN^DIQ1
+ ..Q:'$D(ECXARR)
+ ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100)
  ;if ecxall=0, then user selects pharmacy site(s)
  I ECXALL=0 S OUT=0 D
  .F  Q:OUT!ECXERR  D
- ..N DIC,X,Y,DUOUT,DTOUT
- ..S DIC="^PS(59,",DIC(0)="AEMQZ"
- ..D DIC^PSODI(59,.DIC,.X)
+ ..S DIC="^PS(59,",DIC(0)="AEMQZ" K X,Y D ^DIC
  ..I $G(DUOUT)!($G(DTOUT)) S OUT=1,ECXERR=1 Q
  ..I Y=-1,X="" S OUT=1 Q
- ..D PSS^PSO59(+Y,,"ECXDSS")
- ..Q:'$D(@ARRAY)
- ..S ECXDIV(ECXIEN)=ECXIEN_U_@ARRAY@(ECXIEN,.01)_U_^(.06)_U_^(100)
+ ..K ECXARR S (ECXIEN,DA)=+Y,DIC="^PS(59,",DR=".01;.06;100",DIQ="ECXARR" D EN^DIQ1
+ ..Q:'$D(ECXARR)
+ ..S ECXDIV(ECXIEN)=ECXIEN_U_ECXARR(59,ECXIEN,.01)_U_ECXARR(59,ECXIEN,.06)_U_ECXARR(59,ECXIEN,100)
  ;
  I ECXERR=1 K ECXDIV
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXEC.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXEC.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXEC.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract  ; 10/2/07 2:33pm
- ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92,105**;Dec 22, 1997;Build 70
+ECXEC ;ALB/JAP,BIR/JLP,PTD-DSS Event Capture Extract  [ 02/14/97   2:26 PM ] ; 12/2/04 12:35pm
+ ;;3.0;DSS EXTRACTS;**11,8,13,24,27,33,39,46,49,71,89,92**;Dec 22, 1997;Build 30
 BEG ;entry point from option
  I '$D(^ECH) W !,"Event Capture is not initialized",!! Q
@@ -67,12 +67,6 @@
  F I=1:1:3 S Y=$O(ECXPRV("")) I Y'="" S @("ECU"_I)=+ECXPRV(Y) K ECXPRV(Y)
  S:$L(ECU1) ECXPPC1=$$PRVCLASS^ECXUTL(ECU1,ECDT),ECU1A="2"_$P(ECU1,";")
- S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU1,ECDT)
- S:+ECXUSRTN'>0 ECXUSRTN="" S ECU1NPI=$P(ECXUSRTN,U)
  S:$L(ECU2) ECXPPC2=$$PRVCLASS^ECXUTL(ECU2,ECDT),ECU2A="2"_$P(ECU2,";")
- S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU2,ECDT)
- S:+ECXUSRTN'>0 ECXUSRTN="" S ECU2NPI=$P(ECXUSRTN,U)
  S:$L(ECU3) ECXPPC3=$$PRVCLASS^ECXUTL(ECU3,ECDT),ECU3A="2"_$P(ECU3,";")
- S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECU3,ECDT)
- S:+ECXUSRTN'>0 ECXUSRTN="" S ECU3NPI=$P(ECXUSRTN,U)
  ;change for version 2 where ECP is a variable pointer and we want to
  ;expand it category = category or null if stored as 0
@@ -128,9 +122,9 @@
  ;ECPCE7^^dss identifier ECDSS^dss dept
  ;node1
- ;mpi ECXMPI^dss dept ECXDSSD^PLACEHOLDER
- ;placeholder^placeholder^placeholder^
- ;placeholder^pc prov person class ECCLAS^
+ ;mpi ECXMPI^dss dept ECXDSSD^provider npi ECXPRV2^
+ ;provider #2 npi ECU2NPI^provider #3 npi ECU3NPI^^
+ ;pc provider npi ECPTNPI^pc prov person class ECCLAS^
  ;assoc pc prov ECASPR^assoc pc prov person class ECCLAS2^
- ;placeholder^
+ ;assoc pc prov npi ECASNPI^
  ;divison ECXDIV^mst status ECXMST^dom ECXDOM^date of birth ECXDOB^
  ;enrollment category ECXCAT^ enrollment status ECXSTAT^enrollment
@@ -147,7 +141,5 @@
  ;ECXNPRFI^emerg response indic(FEMA) ECXERI^agent orange indic ECXAO^
  ;environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL
- ;^radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT
- ;^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^
- ;provider npi ECU1NPI^provider #2 ECU2NPI^provider #3 ECU3NPI
+ ;^radiation ECXIR
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -161,6 +153,6 @@
  S ECODE=ECODE_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
  S ECODE=ECODE_ECSC_U_ECPCE7_U_U_ECDSS_U_U
- S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_U_ECCLAS_U
- S ECODE1=ECODE1_U_ECASPR_U_ECCLAS2_U_U_ECXDIV_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI_U_ECCLAS_U
+ S ECODE1=ECODE1_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDIV_U
  S ECODE1=ECODE1_ECXMST_U_ECXDOM_U_ECXDOB_U_ECXCAT_U_ECXSTAT_U
  S ECODE1=ECODE1_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U_ECXOBS_U_ECXENC_U_ECXAOL_U
@@ -171,5 +163,4 @@
  I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
  I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
- I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECU1NPI_U_ECU2NPI_U_ECU3NPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXFELOC.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXFELOC.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXFELOC.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96  8:41 AM ] ; 6/12/07 6:29am
- ;;3.0;DSS EXTRACTS;**1,8,105**;Dec 22, 1997;Build 70
+ECXFELOC ;BIR/DMA,CML-Print Feeder Locations; [ 05/07/96  8:41 AM ]
+ ;;3.0;DSS EXTRACTS;**1,8**;Dec 22, 1997
 EN ;entry point from option
  W !!,"Print list of feeder locations.",! S QFLG=1
@@ -16,10 +16,8 @@
 CLI S EC=0 F  S EC=$O(^SC(EC)) Q:'EC  I $D(^(EC,0)) S EC1=^(0),ECS=$P(EC1,U,15),ECSC=$P($G(^DIC(40.7,+$P(EC1,U,7),0)),U,2),ECD=$P(EC1,U) S:'ECS ECS=1 D
  .I $P(EC1,U,17)'="Y",$P(EC1,U,3)="C" S DAT=$G(^SC(EC,"I")),ID=+DAT,RD=$P(DAT,U,2) I 'ID!(ID>DT)!(RD&(RD<DT)) S ^TMP($J,"CLI",ECS_ECSC,EC)=ECD
-PRE N ARRAY S ARRAY="^TMP($J,""ECXDSS"")" K @ARRAY D PSS^PSO59(,"??","ECXDSS") I @ARRAY@(0)>0 G V6
- ;dbia (#4689)
+PRE I $O(^PS(59,0)) G V6
  S EC=0 F  S EC=$O(^DIC(59,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1
  G RAD
-V6 S EC=0 F  S EC=$O(@ARRAY@(EC)) Q:'EC  I $D(^(EC)) S EC1=$E(@ARRAY@(EC,.01),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1
- K @ARRAY
+V6 S EC=0 F  S EC=$O(^PS(59,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$E($P(^(0),U),1,30),^TMP($J,"PRE","PRE"_EC,EC)="Prescriptions-"_EC1
 RAD S EC=0 F  S EC=$O(^RA(79,EC)),EC1=0 Q:'EC  I $D(^(EC,0)) S ECD=$P(^(0),U) F  S EC1=$O(^RA(79.2,EC1)) Q:'EC1  I $D(^(EC1,0)) S ECD1=$P(^(0),U),^TMP($J,"RAD",EC_"-"_EC1,EC_"-"_EC1)=ECD_"-"_ECD1
 NUR S EC=0 F  S EC=$O(^NURSF(211.4,EC)) Q:'EC  I $D(^(EC,0)) S EC1=$P(^(0),U),EC1=$P($G(^SC(+EC1,0)),U),^TMP($J,"NUR",EC,EC)=EC1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXKILL.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXKILL.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXKILL.m	(revision 636)
@@ -1,9 +1,7 @@
-ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 5/30/2007
- ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89,92,105**;Dec 22, 1997;Build 70
+ECXKILL ;BIR/DMA,PTD-Kill Local Variables ; 9/13/05 10:24am
+ ;;3.0;DSS EXTRACTS;**9,8,21,24,31,39,49,84,89**;Dec 22, 1997
  ;
  K %,%DT,%Y,%ZIS,A,A1,A2,ABR,B,BY,D,D0,D1,DA,DAT,DATA,DATA1,DATA2,DATA6
  K DATAOP,DD,DFN,DHDH,DIC,DIE,DIK,DINUM,DIQ
- K ECDAPRNP,ECDPRNPI,ECISNPI,ECDOCNPI
- K ECU1NPI,ECU2NPI,ECU3NPI
  K DIR,DIRUT,DO,DR,DTOUT,DUOUT,EC,EC0,EC1,EC10,EC11,EC16,EC2,EC23,EC2NODE
  K EC3,EC42,EC50,EC6,EC7,ECA,ECAC,ECACA,ECAD,ECADM,ECALL
@@ -18,6 +16,5 @@
  K ECXMISS,ECMN,ECMOD,ECMODS,ECMORE,ECMS,ECMSG,ECMSN,ECMT,ECMW,ECMY,ECN
  K ECNA,ECNDC,ECNDF,ECNFC,ECNL,ECNO,ECNODE,ECNOGO
- K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECODE2,ECOLD,ECONE,ECOPAY
- K ECATTNPI,ECPWNPI,ECXUSNPI,ECPWNPI,ECXOEF,ECXOEFDT,ECPLACE
+ K ECNT,ECO,ECO0,ECO1,ECO2,ECOB,ECODE,ECODE0,ECODE1,ECOLD,ECONE,ECOPAY
  K ECOPAYT,ECORTY,ECOS,ECP,ECPACK,ECPCE,ECPCE1,ECPCE2,ECPCE3,ECPCE4
  K ECPCE5,ECPCE6,ECPCE7,ECPIECE,ECPN,ECPRC,ECPRO,ECODE2
@@ -29,5 +26,5 @@
  ;
 AUDIT ;kill audit report variables, close slave printer
- K %DT,ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV
+ K ECX,ECXARRAY,ECXACC,ECXALL,ECXAUD,ECXCODE,ECXD,ECXDEF,ECXDESC,ECXDIV
  K ECXRCST,ECXRQST,ECXEND,ECXERR,ECXEXT,ECXHEAD,ECXLOC,ECXPGM,ECXPHCPC
  K ECXPRIME,ECXPRO,ECXREPT,ECXRUN,ECXSAVE,ECXSTART,ECXSRCE
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLABN.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXLABN.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLABN.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 10/23/07 3:01pm
- ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107,105**;Dec 22, 1997;Build 70
+ECXLABN ;ALB/JAP,BIR/CML-Lab Extract for DSS (New Format - With LMIP Codes) ; 4/25/07 8:52am
+ ;;3.0;DSS EXTRACTS;**1,11,8,13,28,24,30,31,32,33,39,42,46,70,71,80,92,107**;Dec 22, 1997;Build 9
 BEG ;entry point
  D SETUP I ECFILE="" Q
@@ -22,7 +22,5 @@
  F  S ECLRN=$O(^LRO(64.03,ECLRN)) Q:'ECLRN  D  Q:QFLG
  .Q:'$D(^LRO(64.03,ECLRN,0))
- .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2)
- .S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(EC1,U,2),$P(EC1,U,4))
- .S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U)
+ .S EC1=^LRO(64.03,ECLRN,0),ECDOC=ECPROF_$P(EC1,U,2),ECDOCNPI=""
  .S ECLOC=$P(EC1,U,15),EC=$P(EC1,U,3),ECDOCPC=$$PRVCLASS^ECXUTL($P(EC1,U,2),$P(EC1,U,4))
  .I EC]"" D GET
@@ -32,7 +30,7 @@
  ;
 GET ;get data
- N X,ECXSTN,QFLAG
+ N X,ECXSTN
  S ECF=$S($P(EC,";",2)="DPT(":2,$P(EC,";",2)="LRT(67,":67,1:0) Q:'ECF
- S ECIFN=$P(EC,";"),QFLAG=0
+ S ECIFN=$P(EC,";")
  ;resolve ecloc
  S ECXL1=+$P(ECLOC,";",1),ECXL2=$P(ECLOC,";",2)
@@ -51,5 +49,5 @@
  Q:ECXERR
  ;get patient data if record is in file #67
- I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D  Q:QFLAG
+ I ECF=67 S ECSN="000123456",ECNA="RFRL" I $D(^LRT(67,ECIFN,0)) D
  .S ECXMPI="",EC0=^LRT(67,ECIFN,0),ECNA=$E($P($P(EC0,U),",")_"    ",1,4)
  .S ECSN=$P(EC0,U,9),ECXERI="" D
@@ -60,5 +58,4 @@
  ..I $L(ECSN)=9,ECSN'?9N S ECSN="000123456" Q
  ..I $L(ECSN)=10,ECSN'?9N1"P" S ECSN="000123456"
- ..I '$$SSN^ECXUTL5(ECSN,ECF) S QFLAG=1
  ;
  ;- Only set treating spec (TS) to TS in file #64.03 if it does not exist
@@ -120,6 +117,5 @@
  ;ord stop code ECXORDST^ord date ECXORDDT^production division
  ;ECXPDIV^^ordering provider person class^emergency response indicator
- ;(FEMA) ECXERI^associate pc provider npi ECASNPI^primary care provider
- ;npi ECPTNPI^provider npi ECDOCNPI
+ ;(FEMA) ECXERI
  ;ECDOCPC
  N DA,DIK
@@ -135,10 +131,9 @@
  S ECODE=ECODE_ECPTTM_U_ECPTPR_U
  ;(ECACA=acc area^abbreviation)
- S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U
- S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
+ S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U
  S ECODE1=ECODE1_ECXORDST_U_ECXORDDT_U_ECXPDIV_U
  I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECDOCPC
  I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
- I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECPTNPI_U_ECDOCNPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLABR.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXLABR.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLABR.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 6/5/07 2:33pm
- ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107,105**;Dec 22, 1997;Build 70
+ECXLABR ;ALB/JAP,BIR/CML-LAR Extract for DSS (New Format - With LMIP Codes) ; 4/12/07 8:43am
+ ;;3.0;DSS EXTRACTS;**8,24,33,37,39,46,71,80,107**;Dec 22, 1997;Build 9
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -31,6 +31,4 @@
  ..S ECXDATE=$P(EC1,U,9)_"."_$P(EC1,U,10)
  ..I ECPTPR S ECCLASS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
- ..I ECPTPR S ECPTNPI=$$NPI^XUSNPI("Individual_ID",ECPTPR,+ECXDATE) D
- ...S:+ECPTNPI'>0 ECPTNPI="" S ECPTNPI=$P(ECPTNPI,U)
  ..S ECORDT=$$ECXDATE^ECXUTL($P(EC1,U,4),ECXYM)
  ..S ECORTM=$$ECXTIME^ECXUTL($P(EC1,U,4)_"."_$P(EC1,U,5))
@@ -93,5 +91,5 @@
  ;observ pat ind (ECXOBS)^encounter num (ECXENC)^prod div ECXPDIV^
  ;lab results translation ECXTRANS^ordering provider (ECPTPR)^
- ;ordering provider person class (ECCLASS)^ordering provider npi ECPTNPI
+ ;ordering provider person class (ECCLASS)
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -107,5 +105,4 @@
  S ECODE1=ECXMPI_U_ECXDSSD_U_ECXDOM_U_ECSCTM_U_ECXOBS_U_ECXENC_U_ECXPDIV_U_ECTRANS
  I ECXLOGIC>2004 S ECODE1=ECODE1_U_2_ECPTPR_U_ECCLASS
- I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECPTNPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLBB.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXLBB.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXLBB.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 10/17/07 10:33am
- ;;3.0;DSS EXTRACTS;**78,84,90,92,104,105**;Dec 22, 1997;Build 70
+ECXLBB ;DALOI/KML - DSS BLOOD BANK EXTRACT ; 2/22/07 11:42am
+ ;;3.0;DSS EXTRACTS;**78,84,90,92,104**;Dec 22, 1997;Build 8
  ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021
  ; access to the LAB DATA file (#63) is supported by 
@@ -12,5 +12,5 @@
 START ; Entry point from tasked job
  ; begin package specific extract
- N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC,ECPHYNPI
+ N ECTRSP,ECADMT,ECTODT,ECENCTR,ECPAT,ECLRDFN,ECXPHY,ECXPHYPC
  N ECD,ECXDFN,ECARRY,EC66,ECERR,ECTRFDT,ECTRFTM,ECX,ECINOUT,ECXINST
  ;variables ECFILE,EC23,ECXYM,ECINST,ECSD,ECSD1,ECED passed in 
@@ -37,5 +37,5 @@
  .; ECARRY(7)=VOLUME TRANSFUSED, ECARRY(8)=TRANSFUSION REACTION TYPE
  .; ECARRY(9)=REQUESTING PROVIDER, ECARRY(10)=REQUEST. PROV. PERSON CLASS
- .; ECARRY(11)=UNIT MODIFIED,ECARRY(12)=UNIT MODIFICATION
+ .; ECARRY(11)=UNIT MODIFIED, ECARRY(12)=UNIT MODIFICATION
  .; ECARRY(13)=PRODUCTION DIVISION CODE
  . S ECARRY(1)=$P(EC0,"^"),EC66=$G(^LAB(66,$P(EC0,"^",2),0))
@@ -45,11 +45,11 @@
  . S ECARRY(8)=$E($P($G(^LAB(65.4,+$P(EC0,"^",11),0)),"^"),1,10)
  . S (ECARRY(9),ECARRY(10),ECARRY(13))="" D GETRPRV
- . S ECARRY(11)=$$MODIFIED(),(ECXPHY,ECXPHYPC,ECPHYNPI)=""
- . S ECARRY(12)=$S(ECARRY(11)="Y":$$UNITMODS(),1:"")
+ . S ECARRY(12)=$$UNITMOD(),ECARRY(11)=$S(ECARRY(12)'="":"Y",1:"N")
+ . S (ECXPHY,ECXPHYPC)=""
  . D GETDATA
  . K ECARRY
  Q
  ;
-UNITMODS() ; Get modification criteria from fields #.06 and #3 from file #66
+UNITMOD() ; Get modification criteria from fields #.06 and #3 from file #66
  N MODARY,MO,EC66A,MODSTR,STR3
  S MODARY("DIVIDED")="D",MODARY("POOLED")="P",MODARY("WASHED")="W"
@@ -58,31 +58,18 @@
  S MODARY("IRRADIATED")="I",MODARY("SEPARATED")="S"
  ;if modification criteria is null determine value from description
- S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD^ECXLBB1($P(EC66,"^")))
+ S MODSTR=$S($P(EC66,U,6)'="":$P(EC66,U,6),1:$$CHKMOD($P(EC66,"^")))
  ;get modification criteria for entries at field #3 in file #66
  S MOD=0 F  S MOD=$O(^LAB(66,$P(EC0,"^",2),3,MOD)) Q:'MOD  D
  .S EC66A=$G(^LAB(66,MOD,0)) I EC66A="" Q
- .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD^ECXLBB1($P(EC66A,"^")))
+ .S STR3=$S($P(EC66A,U,6)'="":$P(EC66A,U,6),1:$$CHKMOD($P(EC66A,"^")))
  .I STR3'="",MODSTR'[STR3 S MODSTR=MODSTR_STR3
  Q MODSTR
  ;
-MODIFIED() ; Was unit modified
- ; Init variables
- N XMATCH,UNIT,MOD,COMPID,MODNODE,MODTO
- S (XMATCH,UNIT)=0,MOD=""
- ; Check input
- Q:'$G(ECLRDFN)!'$P(EC0,U,2) "N"
- ;Find xmatch for blood component request
- S XMATCH=$O(^LR(ECLRDFN,1.8,$P(EC0,U,2),1,XMATCH)) Q:'XMATCH "N"
- ;Get blood inventory file (#65) pointer
- S UNIT=$P($G(^LR(ECLRDFN,1.8,$P(EC0,"^",2),1,XMATCH,0)),U)
- ;Look at disposition field (#4.1) in blood inventory file (#65)
- S MOD=$P($G(^LRD(65,+XMATCH,4)),U),COMPID=$P(EC66,U,3)
- ; Get 'the modified to' entry pointer to blood inventory file (#66)
- I MOD="MO" S MODTO=0 F  S MODTO=$O(^LRD(65,+XMATCH,9,MODTO)) Q:'MODTO  D
- .S MODNODE=$G(^LRD(65,+XMATCH,9,MODTO,0)) Q:$P(^(0),U,3)'>1
- .Q:$P(MODNODE,U,2)'=COMPID
- .; Set the modify to unit ien for file (#66)
- Q $S(MOD="MO":"Y",1:"N")
- ;
+CHKMOD(MD) ;check if modifier is contained in string
+ N RES,MODX
+ I MD="" Q ""
+ S (RES,MODX)="" F  S MODX=$O(MODARY(MODX)) Q:MODX=""  D  I RES'="" Q
+ .I MD[MODX S RES=MODARY(MODX)
+ Q RES
 GETRPRV ; get requesting provider, requesting provider person class and 
  ; production division code
@@ -110,6 +97,4 @@
  . S PERCLS=$$GET^XUA4A72(ECARRY(9),ACCDT)
  . I +PERCLS>0 S ECARRY(10)=$P(PERCLS,U,7)
- . S ECREQNPI=$$NPI^XUSNPI("Individual_ID",ECARRY(9),ACCDT)
- . S:+ECREQNPI'>0 ECREQNPI="" S ECREQNPI=$P(ECREQNPI,U)
  . S ECARRY(9)=2_ECARRY(9)
  S DIV=$P($G(^LRO(68,+AREA,1,ACCDT,1,NUM,.4)),U)
@@ -155,5 +140,5 @@
  I $G(ECXLOGIC)>2005 S ECXSTR=ECXSTR_U_ECXPHY_U_ECXPHYPC
  I $G(ECXLOGIC)>2006 D
- .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)_U
+ .S ECXSTR=ECXSTR_U_ECXERI_U_ECARRY(11)_U_ECARRY(12)_U_ECARRY(9)_U_ECARRY(10)_U_ECARRY(13)
  I '$D(ECXRPT) D FILE(ECXSTR) Q
  S ^TMP("ECXLBB",$J,ECXDFN,ECD)=ECXSTR  ;temporary global array
@@ -194,6 +179,5 @@
  ; ordering physician^ordering physician pc^emergency response indicator
  ; (FEMA)^unit modified^unit modification^requesting provider^request. 
- ; provider person class^ordering provider npi ECPHYNPI
- ;ECODE1- requesting provider npi ECREQNPI
+ ; provider person class
  ;note:  DSS product dept and DSS IP # are dependent on the release of
  ; ECX*3*61
@@ -201,8 +185,5 @@
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
  S ECODE=EC7_"^"_ECODE
- I ECXLOGIC>2007 D
- .S ECODE=ECODE_ECPHYNPI_U
- .S ECODE1=$G(ECREQNPI)
- S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=$G(ECODE1),ECRN=ECRN+1
+ S ^ECX(ECFILE,EC7,0)=ECODE,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
  Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXMOV.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXMOV.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXMOV.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 6/6/07 6:46am
- ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84,107,105**;Dec 22, 1997;Build 70
+ECXMOV ;ALB/JAP,BIR/DMA,PTD-Transfer and Discharge Extract ; 8/19/05 9:13am
+ ;;3.0;DSS EXTRACTS;**8,24,33,39,41,42,46,65,84**;Dec 22, 1997
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -60,5 +60,4 @@
  ....S ECXDSC=$$PRIMARY^ECXUTL2(ECXDFN,ECD)
  ....S ECXDPCT=$P(ECXDSC,U),ECXDPR=$P(ECXDSC,U,2),ECXDAPR=$P(ECXDSC,U,5),ECXDPRPC=$P(ECXDSC,U,3),ECXDAPPC=$P(ECXDSC,U,6)
- ....S ECDAPRNP=$P(ECXDSC,U,7),ECDPRNPI=$P(ECXDSC,U,4)
  ...;
  ...;Get production division ;p-46
@@ -84,5 +83,5 @@
  ;disch assoc prim prov ECXDAPR^production division ECXPDIV
  ;^disch prov person class ECXDPRPC^disch assoc prov pe-
- ;rson person class^disch assoc pc prov npi ECDAPRNP^discharge pc provider npi ECDPRNPI
+ ;rson person class
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -95,5 +94,4 @@
  S ECODE1=ECODE1_ECXDPCT_U_ECXDAPR_U_ECXPDIV ;p-46 added ECXPDIV
  I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXDPRPC_U_ECXDAPPC
- I ECXLOGIC>2007 S ECODE1=ECODE1_U_$G(ECDAPRNP)_U_$G(ECDPRNPI)
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXMTL.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXMTL.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXMTL.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 8/17/07 9:52am
- ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92,105**;Dec 22, 1997;Build 70
+ECXMTL ;ALB/JAP - DSS Mental Health Extract ; 9/11/06 11:07am
+ ;;3.0;DSS EXTRACTS;**24,30,33,39,46,49,71,82,84,92**;Dec 22, 1997;Build 30
  ;
 BEG ;entry point from option
@@ -31,5 +31,5 @@
  .S ECXSCNUM=$P(^ECX(ECFILE,JJ,0),U,23),ECXSCNAM=$P(^ECX(ECFILE,JJ,0),U,24)
  .D PAT(ECXDFN,ECXDATE)
- .S (ECXPRCLS,ECPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE)
+ .S (ECXPRCLS,ECXPRNPI,ECXDIV,ECXPDIV)="" I ECXPRV D PROV(.ECXPRV,ECXDATE)
  .S ECXDSSI=""
  .I ECXLOGIC>2003 D
@@ -79,8 +79,4 @@
  S ECXA=$P(X,U),(ECXADT,ECXADMDT)=$P($P(X,U,4),"."),ECXDCDT=$P($P(X,U,6),".")
  S ECXWPRV=$P(X,U,7),ECXATT=$P(X,U,8)
- S ECWPRNPI=$$NPI^XUSNPI("Individual_ID",ECXWPRV,ECXDATE)
- S:+ECWPRNPI'>0 ECWPRNPI="" S ECWPRNPI=$P(ECWPRNPI,U)
- S ECATTNPI=$$NPI^XUSNPI("Individual_ID",ECXATT,ECXDATE)
- S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
  ;Get ward provider and attending phy person classes
  S ECXWPRPC=$P(X,U,11),ECXATTPC=$P(X,U,12)
@@ -92,6 +88,5 @@
  N INST,DGIEN,ARR,DIC,DR,DA,DIQ
  S ECXPRCLS=$$PRVCLASS^ECXUTL(ECXPRV,ECXDATE)
- S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPRV,ECXDATE)
- S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U)
+ S ECXPRNPI=""
  ;get division identifier using provider
  S (ECXDIV,ECXPDIV)=""
@@ -119,10 +114,10 @@
  ;day ECXDATE^division ECXDIV^admit date ECXADMDT^
  ;d/c date ECXDCDT^dss id ECXDSSI^pc team ECPTTM^pc provider ECPTPR^
- ;placeholder^pc prov person class ECCLAS^
- ;provider ECXPRV^placeholder^prov person class ECXPRCLS^
+ ;pc provider npi ECPTNPI^pc prov person class ECCLAS^
+ ;provider ECXPRV^provider npi ECXPRNPI^prov person class ECXPRCLS^
  ;test name ECXSCNAM(?)^test ien ECXSCNUM(?)^scale number^scale name^
  ;test score^scale score^attend phys^ward provider
  ;node1
- ;mpi^assoc pc provider^placeholder^
+ ;mpi^assoc pc provider^assoc pc provider npi^
  ;assoc pc prov person class^asi class^asi special^asi encounter date^
  ;purple heart ind.^dom prrtp & saartp ind.^enrollment cat^
@@ -135,17 +130,15 @@
  ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI
  ;attending phy person class ECXATTPC^ward provider person class 
- ;ECXWPRPC^^agent orange status ECXAST^asso prov npi ECASNPI^att phy
- ;npi ECATTNPI^primary care prov npi ECPTNPI^provider npi ECPRNPI^ward
- ;provider npi ECWPRNPI
+ ;ECXWPRPC^^agent orange status ECXAST
  N DA,DIK,STR
  I $P(^ECX(ECFILE,JJ,0),U,21)="ASI" S $P(^ECX(ECFILE,JJ,1),U,7)=ECXDATE
  S $P(^ECX(ECFILE,JJ,0),U,6,9)=ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE
  S STR=$S(ECXLOGIC<2005:ECXDIV,1:"")_U_ECXADMDT_U_ECXDCDT_U_ECXDSSI_U_ECPTTM_U_ECPTPR_U
- S STR=STR_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR=""
- S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_U_ECXPRCLS
+ S STR=STR_ECPTNPI_U_ECCLAS,$P(^ECX(ECFILE,JJ,0),U,10,17)=STR,STR=""
+ S $P(^ECX(ECFILE,JJ,0),U,18,20)=ECXPRV_U_ECXPRNPI_U_ECXPRCLS
  S $P(^ECX(ECFILE,JJ,0),U,23,24)=ECXSCNUM_U_ECXSCNAM
  S $P(^ECX(ECFILE,JJ,0),U,27,29)=ECXATT_U_ECXWPRV_U
  I '$D(^ECX(ECFILE,JJ,1)) S ^ECX(727.812,JJ,1)="^^^^^"
- S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_U_ECCLAS2
+ S $P(^ECX(ECFILE,JJ,1),U,1,4)=ECXMPI_U_ECASPR_U_ECASNPI_U_ECCLAS2
  S STR=ECXPHI_U_ECXDOM_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U
  S STR=STR_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXDOB_U_ECXPDIV_U_ECXDEPT_U
@@ -154,7 +147,5 @@
  I ECXLOGIC>2005 S STR=STR_U_ECXATTPC_U_ECXWPRPC
  S $P(^ECX(ECFILE,JJ,1),U,8,22)=STR
- I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST_U
- I ECXLOGIC>2007 S $P(^ECX(ECFILE,JJ,1),U,35)=ECASNPI_U_ECATTNPI_U_ECPTNPI_U D
- . S ^ECX(ECFILE,JJ,2)=ECPRNPI_U_ECWPRNPI
+ I ECXLOGIC>2006 S $P(^ECX(ECFILE,JJ,1),U,34)=ECXAST
  S DA=JJ,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
  S ECRN=ECRN+1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXNUT.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXNUT.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXNUT.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXNUT ;ALB/JRC Nutrition DSS Extract ; 9/24/07 9:33am
- ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70
+ECXNUT ;ALB/JRC Nutrition DSS Extract ; 4/2/2007
+ ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9
 BEG ;entry point from option
  N EC23,EC7,ECED,ECFILE,ECGRP,ECHEAD,ECINST,ECPACK,ECPIECE,ECRN,ECRTN,ECSD1,ECVER,ECXYM
@@ -9,7 +9,7 @@
 START ; start package specific extract
  ;Init variables
- N ECSD,ARRAY
- S ECED=ECED+.3,ECSD=ECSD1,ARRAY="^TMP($J,""FH"")"
- K @ARRAY
+ N ECSD
+ S ECED=ECED+.3,ECSD=ECSD1
+ K ^TMP($J,"FH")
  ;
  ;Call n&fs api and store in ^TMP($J,"FH" global
@@ -20,5 +20,5 @@
  ;
  ;kill ^tmp global
- K @ARRAY
+ K ^TMP($J,"FH")
  ;
  Q
@@ -27,11 +27,8 @@
  ;Init variables
  N ECXORDPC,ECXSSN,ECXPNM,ECXSEX,ECXDOB,ECXMPI,ECXRC1,ECXETH,ECXVET,ECXENRL,ECXELIG,ECXMST,ECXPST,ECXPLOC,ECXPHI,ECXMNS,ECXSTATE,ECXCNTY,ECXZIP,ECXPOS,ECXAST,ECXAOL,ECXRST,ECXEST,ECXTM,ECXDATE,ECXMN,ECXSPC
- N ECXADMDT,ECXWRD,ECXFAC,ECXPRV,ECXPRNPI,ECXATT,ECXATNPI,ECXDOM,ECXATTPC,ECXPRVPC,ECXPDIV,ECXCBOC,ECPTPR,ECCLASS,ECPTTM,ECXOBS,ECXHNCI,ECXNPRFI,ECXERI,ECXENC,ECPAT,ECXERR,ADM,W,X,ECXCAT,ECXCVE,ECXPRIOR,ECXPTYPE,ECXSTAT,ECXUESTA,ECXA,ECORNPI
- N ECXOEF,ECXOEFDT
+ N ECXADMDT,ECXWRD,ECXFAC,ECXPRV,ECXPRNPI,ECXATT,ECXATNPI,ECXDOM,ECXATTPC,ECXPRVPC,ECXPDIV,ECXCBOC,ECPTPR,ECCLASS,ECPTTM,ECXOBS,ECXHNCI,ECXNPRFI,ECXERI,ECXENC,ECPAT,ECXERR,ADM,W,X,ECXCAT,ECXCVE,ECXPRIOR,ECXPTYPE,ECXSTAT,ECXUESTA,ECXA
  ;
  ;- Prefix ordering pro with a 2 and get person class
  S ECXORDPC=$$PRVCLASS^ECXUTL(+ECXORDPH,DATE)
- S ECORNPI=$$NPI^XUSNPI("Individual_ID",+ECXORDPH,DATE)
- S:+ECORNPI'>0 ECORNPI="" S ECORNPI=$P(ECORNPI,U)
  S ECXORDPH=$S(ECXORDPH:2_ECXORDPH,1:"")
  ;
@@ -45,13 +42,9 @@
  S ECXPOS=ECPAT("POS"),ECXAST=ECPAT("AO STAT"),ECXAOL=ECPAT("AOL"),ECXRST=ECPAT("IR STAT"),ECXEST=ECPAT("EC STAT")
  ;
- ;Get oef/oif data
- S ECXOEF=ECPAT("ECXOEF")
- S ECXOEFDT=ECPAT("ECXOEFDT")
- ;
  ;Get enrollment status
  I $$ENROLLM^ECXUTL2(ECXDFN)
  ;
  S ECXTM=$$ECXTIME^ECXUTL(DATE)
- S ECXDATE=$$ECXDATE^ECXUTL(+DATE,ECXYM)
+ S ECXDATE=DATE
  ;
  ;- Use movement record date & time
@@ -67,5 +60,5 @@
  ;- Get primary care data
  S X=$$PRIMARY^ECXUTL2(ECXDFN,DATE)
- S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U),ECPTNPI=$P(X,U,4)
+ S ECPTPR=$P(X,U,2),ECCLASS=$P(X,U,3),ECPTTM=$P(X,U)
  ;
  ;- Observation patient indicator (YES/NO)
@@ -115,7 +108,6 @@
  ;facility^delivery location type^delivery feeder location^quantity^
  ;cboc^status^user enrollee^patient type^cv status eligibility^
- ;national patient record flag^emergency response indicator^admission
- ;date^oef/oif ECXOEF^oef/oif return date ECXOEFDT^ordering provider
- ;npi ECORNPI^primary care provider npi ECPTNPI
+ ;national^patient record flag^emergency response indicator^admission
+ ;date
  ;
  N DA,DIK,ECODE,ECODE1
@@ -129,5 +121,5 @@
  S ECXSPC=$G(ECXDATA(7))
  ;
- S ECODE=ECODE_ECXDATE_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(DATE,ECXYM)_U_ECXTM_U_ECXSPC_U_ECXORDPH_U_ECXORDPC_U
  S ECODE=ECODE_ECPTPR_U_ECCLASS_U_ECPTTM_U_ECXMPI_U_ECXDOB_U_ECXSEX_U
  S ECODE=ECODE_ECXRC1_U_ECXETH_U_ECXVET_U_ECXSTAT_U_ECXENRL_U_ECXCAT_U
@@ -139,5 +131,4 @@
  S ECODE1=ECODE1_ECXCBOC_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXNPRFI_U
  S ECODE1=ECODE1_ECXERI_U_$S(ECXADMDT:$$ECXDATE^ECXUTL(ECXADMDT,ECXYM),1:"")
- I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECXOEF_U_ECXOEFDT_U_$G(ECXTFU)_U_ECORNPI_U_ECPTNPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
  S ECRN=ECRN+1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXNUT1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXNUT1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXNUT1.m	(revision 636)
@@ -1,129 +1,69 @@
-ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 11/23/07 12:27pm
- ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70
+ECXNUT1 ;ALB/JRC Nutrition DSS Extract ; 10/27/06 1:53pm
+ ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30
  Q
+ ;
 GETMEALS ;get patient meals 
- ; variable names:   ordate - regular diet order date
- ;                   sdate  - diet order npo/withhold date
- ;                   norder - "sf" or "so" order date
- ;                             note: there is a relationship
- ;                             between "sf", "so" and regular diets
- ;                   adate - admission date
- ;                   ddate - discharge date
- N I,J,P,D,ECXADM,FHDFN,ORDATE,DATES,NODE,SF,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,MEAL,MEALS,SORDATE,NUMBER,TF,TFNODE,ECXTFU,SDATE
- ;set ecsd to first day of the month before setting meals array
- S ECSD=ECSD+.1,ECXTFU=""
- ;setup individual meals array for inpatients
- F I=ECSD:1:ECED F J=I+.0800,I+.1300,I+.1800 S MEALS(J)=J
- ;get "inp", "sf", and "so" inpatient meals
- S ECXADM=0 F  S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM  D
- .S FHDFN=0 F  S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN  D
- ..S ORDATE=0,(ADATE,DDATE,SDATE)=""
- ..F  S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE  D
- ...Q:$P($G(^TMP($J,"FH",ECXADM,FHDFN,+ORDATE,"INP")),U,7)'=""
- ...S DATES=$$GETDATES(),SDATE=ORDATE
- ...;create regular diet individual meals
- ...S P="INP",D="PD"
- ...;get new order date and time if exist
- ...S NORDER=$$NEWORDER(D,ORDATE)
- ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,ORDATE,"INP")) Q:'NODE
- ...S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_""
- ...;Resolve feeder key for nutrition product
- ...S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT)
- ...I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
- ...S MEAL=ORDATE F  S MEAL=$O(MEALS(MEAL)) Q:'MEAL  D
- ....I $P(DATES,U) Q:MEAL>$P(DATES,U)
- ....I NORDER]"" Q:MEAL>NORDER
- ....I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3)
- ....S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I")
- ....;Get additional data and file record.
- ....S DATE=MEAL D GET^ECXNUT
- ;create supplemental feeding meals if they exist
- S ECXADM=0 F  S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM  D
- .S FHDFN=0 F  S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN  D
- ..S ORDATE=0,(ADATE,DDATE,SDATE)=""
- ..F  S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE  D
- ...S DATES=$$GETDATES()
- ...;get "sf" orders if they exist
- ...N SFNODE S (SFNODE,ECXORDPH,CDATE)=""
- ...S SFNODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SF"))
- ...I +SFNODE D
- ....S P="INP",D="SF"
- ....;get new order date and time if exist
- ....S NORDER=$$NEWORDER(D,ORDATE),CDATE=$P(SFNODE,U,32)
- ....;order thru all "sf" product fields and generate records
- ....F SF=5:2:27 S PRODUCT=$P(SFNODE,U,SF) S ECXQTY=$P(SFNODE,U,(SF+1)) D
- .....Q:PRODUCT']""
- .....;Resolve external value for product key
- .....S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT)
- .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
- .....;create individual meals
- .....F MEAL=ECSD:1:ECED D
- ......I CDATE]"" Q:MEAL>CDATE
- ......I NORDER]"" Q:MEAL>NORDER
- ......I $P(DATES,U,3)]"" Q:MEAL>$P(DATES,U,3)
- ......;Get additional data and file record.
- ......S DATE=$P(MEAL,".")_"."_$S("57911"[SF:10,"13151719"[SF:14,1:18)
- ......D GET^ECXNUT
- ;create standing order meals if they exist
- S ECXADM=0 F  S ECXADM=$O(@ARRAY@(ECXADM)) Q:'ECXADM  D
- .S FHDFN=0 F  S FHDFN=$O(@ARRAY@(ECXADM,FHDFN)) Q:'FHDFN  D
- ..S ORDATE=0,(ADATE,DDATE,SDATE)=""
- ..F  S ORDATE=$O(@ARRAY@(ECXADM,FHDFN,ORDATE)) Q:'ORDATE  D
- ...S DATES=$$GETDATES()
- ...N SONODE,NUM S (SONODE,ECXORDPH)="",NUM=0
- ...S NUM=$O(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM)) Q:'NUM  D
- ....S SONODE=$G(@ARRAY@(ECXADM,FHDFN,ORDATE,"SO",NUM))
- ....I +SONODE D
- .....;create standing order meals
- .....N SMEAL S P="INP",D="SO"
- .....;get new order date and time if exist
- .....S NORDER=$$NEWORDER(D,ORDATE),SMEAL=$P(SONODE,U,3)
- .....S PRODUCT=$P(SONODE,U,2),ECXQTY=$P(SONODE,U,8)
- .....;Resolve feeder key for nutrition product
- .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT)
- .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
- .....;create individual meals
- .....S MEAL=ORDATE F  S MEAL=$O(MEALS(MEAL)) Q:'MEAL  D
- ......N TIME S TIME=$P(MEALS(MEAL),".",2)
- ......Q:SMEAL'["B"&(TIME=08)
- ......Q:SMEAL'["N"&(TIME=13)
- ......Q:SMEAL'["E"&(TIME=18)
- ......I $P(DATES,U) Q:MEAL>$P(DATES,U)
- ......I NORDER]"" Q:MEAL>NORDER
- ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3)
- ......;Get additional data and file record.
- ......S DATE=MEAL D GET^ECXNUT
- ;remove individual meals array
- K MEALS
+ ;init variables
+ N DATE,FHDFN,ECXADM,NODE,PRODUCT,ECXQTY,ORDER,ECXORDPH,ECXKEY,P,D
+ N ECXFPD,ECXFDD,ECXFPF,ECXDLT,ECXDFL,NUMBER,PNODE,SF,TF,TFNODE
+ ;S (DATE,FHDFN,NUMBER,ECXQTY)=0,(ECXADM,NODE,ORDER,ECXORDPH)=""
+ ;Get inpatient diets
+ ;S P="INP",D="PD" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"INP")) Q:'NODE
+ ;... S PRODUCT=$P(NODE,U,13),ECXQTY=1,ORDER=""_$P(NODE,U,14)_","_""
+ ;... S ECXORDPH=$$GET1^DIQ(100,+ORDER,1,"I")
+ ;... ;Resolve feeder key for nutrition product
+ ;... S ECXKEY=$$NUTKEY^ECXUTL6("PD",PRODUCT)
+ ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;... ;Get additional data and file record.
+ ;... D GET^ECXNUT
+ ;Get inpatient supplemental feedings
+ ;S (FHDFN,DATE)=0,(ECXADM,NODE,ORDER,ECXORDPH)=""
+ ;S P="INP",D="SF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SF")) Q:'NODE
+ ;... F SF=5:2:27 S PRODUCT=$P(NODE,U,SF) Q:PRODUCT']""  S ECXQTY=1 D
+ ;.... S ORDER=""_$P(NODE,U,7)_","_""
+ ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
+ ;.... ;Resolve external value for product key
+ ;.... S ECXKEY=$$NUTKEY^ECXUTL6("SF",PRODUCT)
+ ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;.... ;Get additional data and file record.
+ ;.... D GET^ECXNUT
+ ;Get inpatient standing orders
+ ;S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
+ ;S P="INP",D="SO" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"SO")) Q:'NODE
+ ;... S PRODUCT=$P(NODE,U,2),ECXQTY=1
+ ;... ;Resolve external value for product key
+ ;... S ECXKEY=$$NUTKEY^ECXUTL6("SO",PRODUCT)
+ ;... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;... ;Get additional data and file record.
+ ;... D GET^ECXNUT
  ;Get inpatient tube feedings
- N P1,PNODE,CDATE,ECXTFU,MEALS
- ;set daily meals array for inpatient tube feedings
- F I=ECSD:1:ECED S MEALS(I)=""
- S (FHDFN,DATE,P1,CDATE)=0,(ECXADM,NODE,ECXORDPH,PNODE)=""
- S P="INP",D="TF" F  S ECXADM=$O(^TMP($J,"FH",ECXADM)) Q:'ECXADM  D
- .F  S FHDFN=$O(^TMP($J,"FH",ECXADM,FHDFN))  Q:'FHDFN  D
- ..F  S DATE=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE)) Q:'DATE  D
- ...S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF")) Q:'NODE  D
- ....F  S P1=$O(^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1)) Q:'P1  D
- .....S PNODE=^TMP($J,"FH",ECXADM,FHDFN,DATE,"TF",P1,"P")
- .....S ORDATE=DATE,DATES=$$GETDATES(),CDATE=$P(NODE,U,11)
- .....S PRODUCT=$P(PNODE,U,1),ORDER=""_$P(NODE,U,14)_","_""
- .....S ECXQTY=$S($P(PNODE,U,3)["GM":$P(PNODE,U,3),1:$P(PNODE,U,4))
- .....S ECXTFU=$S($P(PNODE,U,3)["GM":"GM",1:"ML")
- .....;Resolve external value for product key
- .....S ECXKEY=$$NUTKEY^ECXUTL6(D,PRODUCT)
- .....I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
- .....;create daily meals
- .....S MEAL=DATE F  S MEAL=$O(MEALS(MEAL)) Q:'MEAL  D
- ......I $P(DATES,U) Q:MEAL>$P(DATES,U)
- ......I CDATE]"" Q:MEAL>CDATE
- ......I $P(DATES,U,3) Q:MEAL>$P(DATES,U,3)
- ......S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
- ......;Get additional data and file record.
- ......S DATE=MEAL D GET^ECXNUT S DATE=ORDATE
+ ;S (FHDFN,DATE,P)=0,(ECXADM,NODE,ECXORDPH,PNODE)=""
+ ;S P="INP",D="TF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
+ ;. F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ ;.. F  S ECXADM=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM)) Q:'ECXADM  D
+ ;... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF")) Q:'NODE
+ ;... S P=$O(^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P)) Q:'P  D
+ ;.... S PNODE=^TMP($J,"FH",DATE,FHDFN,ECXADM,"TF",P,"P")
+ ;.... S PRODUCT=$P(PNODE,U,1),ECXQTY=$P(PNODE,U,4)
+ ;.... S ORDER=""_$P(NODE,U,14)_","_""
+ ;.... S ECXORDPH=$$GET1^DIQ(100,ORDER,1,"I")
+ ;.... ;Resolve external value for product key
+ ;.... S ECXKEY=$$NUTKEY^ECXUTL6("TF",PRODUCT)
+ ;.... I $$NUTLOC^ECXUTL6(P,D,.ECXFPD,.ECXFDD,.ECXFPF,.ECXDLT,.ECXDFL)
+ ;.... ;Get additional data and file record.
+ ;.... D GET^ECXNUT
  ;Get outpatient recurring meals
- S DATE=0,(ECXADM,NODE,ECXORDPH,ECXTFU)=""
+ S (FHDFN,DATE)=0,(ECXADM,NODE,ECXORDPH)=""
  S P="OP",D="RM" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
- . S FHDFN=0 F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
  .. S NUMBER=0 F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
  ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM")) Q:'NODE
@@ -137,10 +77,10 @@
  ... D GET^ECXNUT
  ;Get outpatient tube feedings
- S DATE=0,(ECXADM,NODE,ECXORDPH)=""
+ S (FHDFN,DATE,NUMBER)=0,(ECXADM,NODE,ECXORDPH)=""
  S P="OP",D="TF" F  S DATE=$O(^TMP($J,"FH",DATE)) Q:'DATE  D
- . S FHDFN=0 F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
- .. S NUMBER=0 F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
- ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:NODE=""
- ... S TF=0 F  S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF  D
+ . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN))  Q:'FHDFN  D
+ .. F  S NUMBER=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER)) Q:'NUMBER  D
+ ... S NODE=$G(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF")) Q:'NODE
+ ... S TF=$O(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)) Q:'TF  D
  .... S TFNODE=^TMP($J,"FH",DATE,FHDFN,NUMBER,"RMTF",TF)
  .... S PRODUCT=$P(TFNODE,U,1),ECXQTY=$P(TFNODE,U,4)
@@ -155,6 +95,5 @@
  . F  S FHDFN=$O(^TMP($J,"FH",DATE,FHDFN)) Q:'FHDFN  D
  .. S NODE=$G(^TMP($J,"FH",DATE,FHDFN,"SM")) Q:'NODE
- .. S PRODUCT=$P(NODE,U,4),ECXQTY=1,ECXORDPH=$P(NODE,U,5)
- .. S PRODUCT=$$GET1^DIQ(111,PRODUCT,4,"I")
+ .. S PRODUCT=$P(NODE,U,13),ECXQTY=1,ECXORDPH=$P(NODE,U,5)
  .. ;Resolve external value for product key
  .. S ECXKEY=$$NUTKEY^ECXUTL6("SM",PRODUCT)
@@ -174,35 +113,2 @@
  .. D GET^ECXNUT
  Q
-GETDATES() ;Get admit, discharge, npo/withhold dates,for "inp", "sf" and "so"
- ;  return in string i.e.  stop date^admission date^discharge date
- ;     input:    ecxadm  -  movement file ien
- ;               fhdfn   - nutrition patient file (#115)
- ;
- ;     output:   stop date  - npo/withhold date
- ;               admit date - admission date and time
- ;               discharge date - discharge date and time
- ;init variables
- N ADATE,DDATE,DATE,STDATE,NORDATE,IENS
- ;check input
- Q:'$G(ECXADM)!'$G(FHDFN) "0^0^0"
- ;get admission and discharge dates
- S (ADATE,DDATE,DATE,SDATE,NORDATE,STDATE)="",IENS=""_ECXADM_","_FHDFN_","_"",ADATE=$$GET1^DIQ(115.01,IENS,.01,"I"),DDATE=$$GET1^DIQ(115.01,IENS,18,"I")
- ;get "inp" order's npo/withhold date return it as 'stdate' if exist
- S DATE=ORDATE F  S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE  D
- .I $P($G(@ARRAY@(ECXADM,FHDFN,+DATE,"INP")),U,7)'="" S STDATE=DATE
- Q STDATE_U_ADATE_U_DDATE
-NEWORDER(TYPE,DATE) ;Look for new order for inpatient meal type if exist
- ;    Input     ecxadm -  movement #
- ;              fhdfn  -  nutrition file (#115) fhdfn
- ;              date   -  starting order date to begin lookup
- ;              type   -  meal type "sf", "so", or "pd"
- ;    Output:   new order date and time for specific meal type
- ;init variables
- N NORDER
- S NORDER=""
- ;check input
- Q:$G(TYPE)']""!'$G(DATE) NORDER
- F  S DATE=$O(@ARRAY@(ECXADM,FHDFN,DATE)) Q:'DATE  Q:NORDER  D
- .S NODE=$G(^TMP($J,"FH",ECXADM,FHDFN,DATE,TYPE)) Q:'NODE
- .S NORDER=DATE
- Q NORDER
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXOPRX.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXOPRX.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXOPRX.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/5/07 8:17am
- ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92,105**;Dec 22, 1997;Build 70
+ECXOPRX ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 11/2/06 8:42am
+ ;;3.0;DSS EXTRACTS;**10,11,8,13,24,30,33,38,39,46,49,71,81,84,92**;Dec 22, 1997;Build 30
  ;
 BEG ;entry point from option
@@ -41,6 +41,4 @@
  ;- Get provider (either 2_provider or 6_provider depending on version)
  S ECXPROV=$S($P(ECDATA,U,4)'="":ECPROF_$P(ECDATA,U,4),1:""),ECXPROVP=$$PRVCLASS^ECXUTL($P(ECDATA,U,4),ECXDATE)
- S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$P(ECDATA,U,4),ECXDATE)
- S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
  ;get classification data
  S ECXCLS=$G(^PSRX(ECRX,"IBQ")),ECXMIL=$P(ECXCLS,U,2),ECXAO=$P(ECXCLS,U,3),ECXIR=$P(ECXCLS,U,4),ECXECE=$P(ECXCLS,U,5),ECXHNC=$P(ECXCLS,U,6)
@@ -86,5 +84,5 @@
 PAT(ECXDFN,ECXDATE,ECXERR) ;Determine in/outpatient status, movement number, primary care team and provider
  N OK,X,PT
- S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
+ S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)=""
  ;get patient data if saved
  I $D(^TMP($J,"ECXP",ECXDFN)) D
@@ -94,5 +92,5 @@
  .S ECXPHI=$P(PT,U,20),ECXCAT=$P(PT,U,21),ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23)
  .S ECXCNHU=$P(PT,U,24),ECXPOS=$P(PT,U,25),ECXAOL=$P(PT,U,26),ECXHNCI=$P(PT,U,27),ECXETH=$P(PT,U,28),ECXRC1=$P(PT,U,29),ECXMTST=$P(PT,U,30)
- .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4)
+ .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2)
  .I $$ENROLLM^ECXUTL2(ECXDFN)
  ;set patient data
@@ -110,10 +108,7 @@
  .S ECXHNCI=$$HNCI^ECXUTL4(ECXDFN) ;Head and Neck Cancer Indicator
  .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1") ;Race and Ethnicity
- .; OEF/OIF data
- .S ECXOEF=ECXPAT("ECXOEF")
- .S ECXOEFDT=ECXPAT("ECXOEFDT")
  .S ^TMP($J,"ECXP",ECXDFN)=ECXSSN_U_ECXPNM_U_ECXMPI_U_ECXSEX_U_ECXDOB_U_ECXELIG_U_ECXVET_U_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U_ECXMST_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXENRL_U_U
  .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXPHI_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXCNHU_U_ECXPOS_U_ECXAOL_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
- .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT
+ .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST
  ;get inpatient data
  S (ECXA,ECXADMDT,ECXDOM,ECXMN,ECXTS)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE) D
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXOPRX1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXOPRX1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXOPRX1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 6/6/07 7:23am
- ;;3.0;DSS EXTRACTS;**92,107,105**;Dec 22, 1997;Build 70
+ECXOPRX1 ;ALB/JAP,BIR/DMA,CML,PTD-Prescription Extract for DSS ; 4/19/2007
+ ;;3.0;DSS EXTRACTS;**92,107**;Dec 22, 1997;Build 9
  ;
 FILE ;file record
@@ -8,7 +8,7 @@
  ;feeder key^investigational^days supply^primary care team^primary care provider^time^race
  ;node1
- ;mpi^dss dept ECXDSSD^sex^zip+4^placeholder^placeholder^state^county^pc prov person class^pow status^pow location^
+ ;mpi^dss dept ECXDSSD^sex^zip+4^provider npi^pc provider npi^state^county^pc prov person class^pow status^pow location^
  ;ir status^ao status^sharing agree. payor^sharing agree. ins.^mst status^enroll loc^assoc pc provider^assoc pc prov person class^
- ;placeholder^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^
+ ;assoc pc prov npi^dom ECXDOM^purple heart ECXPHI^enrollment category ECXCAT^enrollment status ECXSTST^
  ;enrollment priority ECXPRIOR^cnhu status ECXCNHU^period of service ECXPOS^observ pat ind ECXOBS^encounter num ECXENC^
  ;ao loc ECXAOL^ord physician ECXORDPH^ord stop code ECXORDST^ord date ECXORDDT^CNH status ECXCNH^national division ECXPDIV^
@@ -17,5 +17,4 @@
  ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^rx patient status ECRXPTST^non-va prescriber ECNONVAP^rx # ECRXNUM
  ;^emergency response indicator(FEMA) ECXERI^agent orange enc ECXAO^environ cont PGE ECXECE^head/neck ECXHNC^enc mst ECXMIL^environ contamin ECXEST^ion radiat ECXIR
- ;OEF/OIF data ECXOEF^OEFOIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECPRVNPI
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -31,8 +30,8 @@
  S ECODE=ECODE_ECXELIG_U_ECXVET_U_ECOPAY_U_ECNFC_U_ECINV_U_ECDS_U
  S ECODE=ECODE_ECPTTM_U_ECPTPR_U_$$ECXTIME^ECXUTL(ECXDATE)_U_ECXRACE_U
- S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U_ECXPROVN_U_ECPTNPI_U
  S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECCLAS_U_ECXPST_U_ECXPLOC_U
  S ECODE1=ECODE1_ECXRST_U_ECXAST_U_U_U_ECXMST_U_ECXENRL_U
- S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXPHI_U_ECXCAT_U
+ S ECODE1=ECODE1_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXPHI_U_ECXCAT_U
  S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXPOS_U_ECXOBS_U
  S ECODE1=ECODE1_ECXENC_U_ECXAOL_U_ECXORDPH_U_ECXORDST_U_ECXORDDT_U
@@ -43,5 +42,4 @@
  I ECXLOGIC>2005 S ECODE2=ECODE2_U_ECRXNUM
  I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXEST_U_ECXIR_U_ECXSCRX
- I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECPRVNPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPIVDN.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXPIVDN.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPIVDN.m	(revision 636)
@@ -1,9 +1,4 @@
-ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 10/31/07 1:38pm
- ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107,105**;Dec 22, 1997;Build 70
-BEG ;entry point from option
- D SETUP I ECFILE="" Q
- D ^ECXTRAC,^ECXKILL
- Q
- ;
+ECXPIVDN ;ALB/JAP,BIR/DMA,CML,PTD-Extract from IV EXTRACT DATA File (#728.113) ; 4/19/2007
+ ;;3.0;DSS EXTRACTS;**10,11,8,13,24,33,39,46,49,71,84,96,92,107**;Dec 22, 1997;Build 9
 START ; start package specific extract
  N DIC,DA,DR,DIQ,DFN,ECXNPRFI,ECXPHA
@@ -58,8 +53,5 @@
  I $L(ECNFC)=12 S ECNFC=$$RJ^XLFSTR(P1,4,0)_$$RJ^XLFSTR(P3,3,0)_ECNFC
  ;- Ordering provider ("2"_provider)
- S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:"")
- N ECXUSRTN
- S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",$P(EC,U,10),$P(EC,U,16))
- S:+ECXUSRTN'>0 ECXUSRTN="" S ECXOPNPI=$P(ECXUSRTN,U)
+ S ECXORDPR=$S(+$P(EC,U,10):"2"_$P(EC,U,10),1:""),ECXOPNPI=""
  S ECXORDDT=$P(EC,U,16) ;- Ordering date
  ;- Requesting physician (null for FY2002)
@@ -83,9 +75,9 @@
  ;set national patient record flag if exist
  S ECXDFN=DFN D NPRF^ECXUTL5 K ECXDFN
- D:ECXENC'="" FILE^ECXPIVD2 K P1,P3
+ D:ECXENC'="" FILE K P1,P3
  Q
 PAT(ECXDFN,ECXDATE,ECXERR) ;get patient demographics, primary care, and inpatient data
  N X
- S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
+ S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)=""
  ;get patient data if saved
  I $D(^TMP($J,"ECXP",ECXDFN)) D
@@ -95,5 +87,5 @@
  .S ECXAOL=$P(PT,U,16),ECXPHI=$P(PT,U,17),ECXMST=$P(PT,U,18),ECXENRL=$P(PT,U,19),ECXCNHU=$P(PT,U,20),ECXCAT=$P(PT,U,21)
  .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24),ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
- .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4)
+ .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2)
  .I $$ENROLLM^ECXUTL2(ECXDFN)
  ;set patient data
@@ -113,10 +105,8 @@
  .S ECXETH=ECXPAT("ETHNIC"),ECXRC1=ECXPAT("RACE1")
  .S ECXERI=ECXPAT("ERI") ;emergency response indicator (FEMA)
- .S ECXOEF=ECXPAT("ECXOEF")
- .S ECXOEFDT=ECXPAT("ECXOEFDT")
  .;save for later
  .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
  .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
- .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT
+ .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST
  ;get primary care data
  S X=$$PRIMARY^ECXUTL2(ECXDFN,$P(ECXDATE,"."))
@@ -125,4 +115,45 @@
  S (ECXA,ECXMN,ECXADM,ECXTS,ECXW,ECXDIV)="",X=$$INP^ECXUTL2(ECXDFN,ECXDATE)
  S ECXA=$P(X,U),ECXMN=$P(X,U,2),ECXTS=$P(X,U,3),ECXADM=$P(X,U,4),W=$P(X,U,9),ECXDOM=$P(X,U,10),ECXW=$P(W,";"),ECXDIV=$P(W,";",2)
+ Q
+FILE ;file record
+ ;node0
+ ;fac^dfn^ssn^name^i/o^day^va class^qty^ward^cost^movement #^treat spec^ndc^investigational^iv dispensing fee^new feeder key^total doses^
+ ;primary care team^primary care provider^ivp time^adm date^adm time^dss identifier
+ ;node1
+ ;mpi^dss dept^pc provider npi^pc prov person class^assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^obs pat ind^enc num^
+ ;ord pr^ordering stop code^ord dt^req phys^nat prod division^means tst^elig^dob^sex^state^county^zip+4^vet^period of svc^pow stat^pow loc^ir stat^ao stat^
+ ;ao loc^purple heart ind.^mst stat^enrollment loc^enrollment cat^enrollment stat^enrollment prior^cnh/sh stat^ord pr npi
+ ;node2
+ ;head & neck cancer ind.^ethnicity^race1^bcma drug dispensed^bcma dose given^bcma unit of administration^bcma ICU flag^
+ ;ordering provider person class^^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig ECXCVE^
+ ;combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) ECXERI^
+ ;environ contamin ECXEST
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXDIV_U_DFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECD,ECXYM)_U_ECVACL_U_ECXCNT_U_ECXW_U
+ ;convert specialty to PTF Code for transmission
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXTS,.ECXDATA)
+ S ECXTS=$G(ECXDATA(7))
+ ;done
+ S ECODE=ECODE_ECXCOST_U_ECXMN_U_ECXTS_U_ECNDC_U_ECINV_U_ECTYP_U_ECNFC_U
+ S ECODE=ECODE_ECST_U_ECPTTM_U_ECPTPR_U_ECDTTM_U_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U_$$ECXTIME^ECXUTL(ECXADM)_U_ECXDSSI_U
+ ;if outpat and not observ patient, admit date="" and admit time="000000"
+ I ECXA="O",(ECXOBS="NO") S $P(ECODE,U,24)="",$P(ECODE,U,25)="000000"
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDPR_U
+ S ECODE1=ECODE1_ECXORDST_U_$$ECXDATE^ECXUTL(ECXORDDT,ECXYM)_U_ECXRPHY_U_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U
+ S ECODE1=ECODE1_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST_U
+ S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCAT_U
+ S ECODE1=ECODE1_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXCNHU_U_ECXOPNPI_U
+ S ECODE2=ECXHNCI_U_ECXETH_U_ECXRC1
+ I ECXLOGIC>2003 D
+ .S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC
+ I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
+ S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
  Q
 SETUP ;Set required input for ECXTRAC
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPLBB.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXPLBB.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPLBB.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/13/07 7:08am
- ;;3.0;DSS EXTRACTS;**78,92,105**;Dec 22, 1997;Build 70
+ECXPLBB ;DALOI/KML - DSS BLOOD BANK PRE-EXTRACT AUDIT REPORT ; 8/14/06 10:10am
+ ;;3.0;DSS EXTRACTS;**78,92**;Dec 22, 1997;Build 30
  ;Per VHA Directive 97-033 this routine should not be modified.  Medical Device # BK970021
  ;entry point from option
@@ -39,5 +39,5 @@
 HED ;
  S ECPG=ECPG+1
- W !,"LBB Extract Audit Report",?72,"Page",$J(ECPG,3)
+ W !,"LBB Pre-Extract Audit Report",?72,"Page",$J(ECPG,3)
  W !,ECSDN," - ",ECEDN,?58,"Run Date:",$J(ECRDT,12)
  W !,?37,"Transf",?57,"Number"
@@ -50,5 +50,5 @@
  I '$D(ECNODE) S ECNODE=7
  I '$D(ECHEAD) S ECHEAD=" "
- W @IOF,!,"LBB Extract Audit Report Information for DSS",!!
+ W @IOF,!,"LBB Pre-Extract Audit Report Information for DSS",!!
  S:'$D(ECINST) ECINST=+$P(^ECX(728,1,0),U)
  S ECXINST=ECINST
@@ -78,5 +78,5 @@
  F X="ECFILE","ECHEAD","ECVER","ECINST","ECXINST" S ZTSAVE(X)=""
  F X="ECXLOGIC","ECXDATES" S ZTSAVE(X)=""
- S ZTDESC=ECPACK_" EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO=""
+ S ZTDESC=ECPACK_" PRE-EXTRACT AUDIT REPORT: "_ECSDN_" TO "_ECEDN,ZTRTN="START^ECXPLBB",ZTIO=""
  S IOP="Q" W ! S %ZIS="QMP" D ^%ZIS S:POP ECXPOP=1 Q:POP  I $D(IO("Q")) K IO("Q"),ZTIO D ^%ZTLOAD W:$D(ZTSK) !,$C(7),"REQUEST QUEUED",!,"Task #: ",$G(ZTSK) K I,ZTSK,ZTIO,ZTSAVE,ZTRTN D HOME^%ZIS S ECXPOP=1
  Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPRO.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXPRO.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPRO.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 10/17/07 3:47pm
- ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92,105**;Dec 22, 1997;Build 70
+ECXPRO ;ALB/GTS - Prosthetics Extract for DSS ; 11/2/06 8:56am
+ ;;3.0;DSS EXTRACTS;**9,13,15,21,24,33,39,46,71,92**;Dec 22, 1997;Build 30
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -40,14 +40,7 @@
  ..S ECXFORM=$G(ECXP(660,ECXDACT,11,"E"))_U_$G(ECXP(660,ECXDACT,11,"I"))
  ..Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXCT)
- ..S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT)
- ..I 'OK S ECXERR=1 K ECXPAT Q
- ..;OEF/OIF data
- ..S ECXOEF=ECXPAT("ECXOEF")
- ..S ECXOEFDT=ECXPAT("ECXOEFDT")
  ..Q:'$$NTEG^ECXPRO1(ECXDFN,.ECXLNE,ECXDACT,ECX0,ECXLB,ECINST,ECXFORM)
  ..D PROSINFO^ECXPRO1(ECXDACT,ECXLB,ECX0,ECXFORM)
  ..S CPTCODE=$E(ECXHCPCS,1,5)
- ..;nppd entry date
- ..S ECXNPPDT=$$ECXDATE^ECXUTL($P(ECX0,U,1),ECXYM)
  ..;
  ..;Get production division ;p-46
@@ -97,11 +90,11 @@
  ;icd9-4 (ECXICD94)^agent orange^radiation^env contam^eligibility^
  ;cost^lab labor cost^lab matl cost^billing status^
- ;vet^transaction type^req station^rec station^file#661.1 ien
+ ;vet^transacton type^req station^rec station^file#661.1 ien
  ;node1
- ;zip^dob^sex^amis grouper^placeholder^mpi^dss dept ECXDSSD^
+ ;zip^dob^sex^amis grouper^pc prov npi^mpi^dss dept ECXDSSD^
  ;pc prov person class^race^pow status^pow loc^
  ;sharing agree payor^sharing agree ins^mst status^
  ;enroll loc^state^county^assoc pc provider^
- ;assoc pc prov person class^placeholder
+ ;assoc pc prov person class^assoc pc prov npi
  ;dom (ECXDOM)^purple heart indicator (ECXPHI)^
  ;enrollment Category (ECXCAT)^enrollment status (ECXSTAT)^
@@ -116,7 +109,5 @@
  ;emergency response indicator(FEMA) ECXERI^agent orange indicator ECXAO
  ;^environ contam ECXECE^head/neck cancer ECXHNC^encntr mst ECXMIL^
- ;radiation ECXIR^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^
- ;nppd code ECXNPPDC^nppd entry date ECXNPPDT
- ;assoc pc provider npi ECASNPI^primary care provider npi ECPTNPI
+ ;radiation ECXIR
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -128,15 +119,14 @@
  S ECODE=ECODE_ECXLMC_U_ECXBILST_U_ECXVET_U_ECXTYPE_U_ECXRQST_U_ECXRCST_U
  S ECODE=ECODE_ECXPHCPC_U
- S ECODE1=ECXZIP_U_ECXDOB_U_ECXSEX_U_ECXGRPR_U_U_ECXMPI_U
+ S ECODE1=ECXZIP_U_ECXDOB_U_ECXSEX_U_ECXGRPR_U_ECPTNPI_U_ECXMPI_U
  S ECODE1=ECODE1_ECXDSSD_U_ECCLAS_U_ECXRACE_U_ECXPST_U_ECXPLOC_U
  S ECODE1=ECODE1_U_U_ECXMST_U_ECXENRL_U_ECXSTATE_U
- S ECODE1=ECODE1_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U
+ S ECODE1=ECODE1_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U
  S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U
  S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXCNH_U_ECXPDIV_U
  S ECODE1=ECODE1_ECXHNCI_U_ECXETH_U_ECXRC1_U
  I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
- I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
- I ECXLOGIC>2007 S ECODE2=ECXOEF_U_ECXOEFDT_U_ECXNPPDC_U_ECXNPPDT_U_ECASNPI_U_ECPTNPI
- S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
+ I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
  I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPRO1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXPRO1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXPRO1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; 11/8/07 8:02am
- ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100,105**;Dec 22, 1997;Build 70
+ECXPRO1 ;ALB/GTS - Prosthetics Extract for DSS (Continued) ; DEC 15, 2006
+ ;;3.0;DSS EXTRACTS;**9,11,13,15,21,24,33,37,39,100**;Dec 22, 1997;Build 2
  ;
 NTEG(ECXDFN,ECXLNE,ECXPIEN,ECXN0,ECXNLB,ECINST,ECXFORM) ;** Check for required fields
@@ -22,5 +22,4 @@
  ;    ECXRCST                - Receiving Station
  ;    ECXPHCPC               - PSAS HCPCS code; if 'unknown', then use CPT/HCPCS code 
- ;    ECXNPPDC               - NPPD code for repairs or new issues
  ;   Output (KILLed by NTEG)
  ;    ECXMISS                - 1 indicates missing information
@@ -28,5 +27,5 @@
  ;
  N ECXGOOD,ECXMISS
- S (ECXRCST,ECXRQST,ECXNPPDC)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10)
+ S (ECXRCST,ECXRQST)="",ECXGOOD=1,ECXSTAT2=$P(ECXN0,U,10)
  I ECXSTAT2]"" D
  .K ECXDIC
@@ -46,7 +45,5 @@
  ;get psas hcpcs code from file #661.1
  S ECXPHCPC=$P($G(^RMPR(660,ECXPIEN,1)),U,4) D
- .;get nppd code for repairs and new issues 10 characters in length.
- .I "X5"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",5)," ","_")
- .I "IR"[ECXTYPE S ECXNPPDC=$TR($$GET1^DIQ(661.1,ECXPHCPC_",",6)," ","_")
+ .;I +ECXPHCPC S ECXPHCPC=$P($G(^RMPR(661.1,ECXPHCPC,0)),U,1)
  .I +ECXPHCPC S ECXPHCPC=$E($P($G(^RMPR(661.1,ECXPHCPC,0)),U,1),1,5)
  .I ECXPHCPC="UNKNOWN" S ECXPHCPC=$E(ECXHCPCS,1,5)
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXQSR.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXQSR.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXQSR.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 7/31/07 11:19pm
- ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106,105**;Dec 22, 1997;Build 70
+ECXQSR ;ALB/JAP,BIR/PTD-DSS QUASAR Extract ; 04/16/07 8:58am
+ ;;3.0;DSS EXTRACTS;**11,8,13,26,24,34,33,35,39,43,46,49,64,71,84,92,106**;Dec 22, 1997;Build 1
 BEG ;entry point from option
  I '$O(^ACK(509850.8,0)) W !,"You must be using the Quality Audiology & Speech Pathology",!,"Audit & Review (QUASAR) software to run this extract.",!! Q
@@ -35,10 +35,4 @@
  S ECXDFN=$P(ECZNODE,U,2)
  Q:'$$PATDEM^ECXUTL2(ECXDFN,ECD,"1;3;5")
- S OK=$$PAT^ECXUTL3(ECXDFN,ECDT,"1;5",.ECXPAT)
- I 'OK S ECXERR=1 K ECXPAT Q
- ;OEF/OIF data
- S ECXOEF=ECXPAT("ECXOEF")
- S ECXOEFDT=ECXPAT("ECXOEFDT")
- ;
  S ECHL="",ECXDIV=$P($G(^ACK(509850.6,ECDA,5)),U),ECSTOP=$P(EC2NODE,U)
  S ECXPDIV=$$GETDIV^ECXDEPT(ECXDIV)  ; Get Production Division
@@ -63,10 +57,4 @@
  I +ECXQV=2 D
  .S ECXPRV1=$P(EC2NODE,U,7),ECXPRV2=$P(EC2NODE,U,3),ECXPRV3=$P(EC2NODE,U,5),ECPN=0
- .S ECPR1NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV1,ECD)
- .S:+ECPR1NPI'>0 ECPR1NPI="" S ECPR1NPI=$P(ECPR1NPI,U)
- .S ECPR2NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV2,ECD)
- .S:+ECPR2NPI'>0 ECPR2NPI="" S ECPR2NPI=$P(ECPR2NPI,U)
- .S ECPR3NPI=$$NPI^XUSNPI("Individual_ID",ECXPRV3,ECD)
- .S:+ECPR3NPI'>0 ECPR3NPI="" S ECPR3NPI=$P(ECPR3NPI,U)
  .F  S ECPN=$O(^ACK(509850.6,ECDA,3,ECPN)) Q:'ECPN  D
  ..S XX=^ACK(509850.6,ECDA,3,ECPN,0),XX=$P(XX,U),XX=$P($G(^ACK(509850.4,XX,0)),U),ECXCPT=$E($$CPT^ECXUTL3(XX),1,5)
@@ -140,6 +128,58 @@
  .S:ECXPRV1'="" ECXPPC1=$$PRVCLASS^ECXUTL(ECXPRV1,ECD),ECXPRV1=2_ECXPRV1
  .S ECP=$P(LOC(CPT),U,3) I ECP="" S ECP=$$CPT^ECXUTL3(CPT,"",ECV)
- .D FILE^ECXQSR1
+ .D FILE
  K CPT,LOC
+ Q
+FILE ;file record in #727.825
+ ;node0
+ ;inst^dfn ECXDFN^ssn ECXSSN^name ECXPNM^i/o status ECXA^day ECDAY^
+ ;DSS unit ECDU^^category ECPTTM^procedure ECP^volume ECV^cost center^
+ ;ordering sec ^section^provider ECXPRV1^ECXPPC1^ECXPRV2^ECXPPC2^ECXPRV3^
+ ;ECXPPC3^mov # ECXMN^treat spec ECXTS^time ECTIME^primary care team 
+ ;ECPTTM^primary care provider ECPTPR^pce cpt code & modifers ECXCPT^
+ ;primary icd-9 code ECDIA^secondary icd-9 #1 ECXICD91^secondary icd-9 
+ ;#2 ECXICD92^secondary icd-9 #3 ECXICD93^secondary icd-9 #4 ECXICD94^
+ ;agent orange ECXAST^radiation exposure ECRST^environmental
+ ;contaminants ECEST^service connected ECSC^sent to pce^^dss identifier
+ ;ECDSS^placeholder
+ ;node1
+ ;mpi ECXNPI^dss dept ECXDSSD^provider npi ECUN1NPI^^^pc prov person 
+ ;class ECPTNPI^assoc pc provider ECASPR^assoc pc prov person class 
+ ;ECCLAS2^assoc pc provider npi ECASNPI^divison ECXDIV^dom ECXDOM^
+ ;enrollment category ECXCAT^enrollment status ECXSTAT^enrollment prior 
+ ;ECXPRIOR^period of service ECXPOS^purple heart ECXPHI^observ pat ind 
+ ;ECXOBS^encounter num ECXENC^ao loc ECXAOL^ord div ECXODIV^contr st dt 
+ ;ECXCSDT^contr end dt ECXCEDT^contr typ ECXCTYP^CNH stat ECXCNH^
+ ;production division ECXPDIV^eligibility ECXELIG^ethnicity ECXETH^
+ ;race1 ECXRC1^enrollment location ECXENRL^^enrollment priority 
+ ;ECXPRIOR_enrollment subgroup ECXSBGRP^user enrollee ECXUESTA^patient 
+ ;type ECXPTYPE^combat vet elig ECXCVE^combat vet elig end date ECXCVEDT^
+ ;enc cv eligible ECXCVENC^national patient record flag ECXNPRFI^
+ ;emergency response indicator(FEMA) ECXERI^agent orange indicator 
+ ;ECXAO^environ contam ECXECE^head/neck ECXHNC^military sexual trauma 
+ ;ECXMIL^radiation encoun ECXIR^nutrition dx
+ N DA,DIK
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U
+ S ECODE=ECODE_ECL_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECDAY_U_ECDU_U_U
+ S ECODE=ECODE_ECP_U_ECV_U_ECCS_U_ECO_U_ECM_U_ECXPRV1_U_ECXPPC1_U
+ S ECODE=ECODE_ECXPRV2_U_ECXPPC2_U_ECXPRV3_U_ECXPPC3_U_U
+ S ECODE=ECODE_ECXMN_U_ECXTS_U_ECTIME_U_ECPTTM_U
+ S ECODE=ECODE_ECPTPR_U_ECXCPT_U_ECDIA_U_ECXICD91_U_ECXICD92_U
+ S ECODE=ECODE_ECXICD93_U_ECXICD94_U_ECXAST_U_ECXRST_U_ECXEST_U
+ S ECODE=ECODE_ECSC_U_"N"_U_U_ECDSS_U_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECUN1NPI_U_U_U_ECCLAS_U_ECPTNPI_U_ECASPR_U
+ S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDIV_U_ECXMST_U_ECXDOM_U
+ S ECODE1=ECODE1_ECXDOB_U_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U
+ S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXODIV_U_ECXCSDT_U_ECXCEDT_U
+ S ECODE1=ECODE1_ECXCTYP_U_ECXCNH_U_ECXPDIV_U_ECXELIG_U_ECXHNCI_U_ECXETH_U
+ S ECODE1=ECODE1_ECXRC1
+ I ECXLOGIC>2003 S ECODE1=ECODE1_U_ECXENRL
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U
+ I ECXLOGIC>2004 S ECODE2=ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXECE_U_ECXHNC_U_ECXMIL_U_ECXIR_U
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=$G(ECODE2),ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD
  Q
 SETUP ;Set required input for ECXTRAC
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXRAD.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXRAD.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXRAD.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 5/30/2007
- ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92,105**;Dec 22, 1997;Build 70
+ECXRAD ;ALB/JAP,BIR/PDW,PTD-Extract for Radiology ; 6/23/06 6:52am
+ ;;3.0;DSS EXTRACTS;**11,8,13,16,24,33,39,46,71,84,92**;Dec 22, 1997;Build 30
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -17,5 +17,5 @@
  ;
 GET ;get data
- N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC,ECXUSRTN
+ N ECXIEN,X,SUB,TYPE,ECDOCPC,ECXIS,ECXISPC,ECXPRCL,ECXCSC
  S ^TMP("ECL",$J,ECXDFN)=""
  ;with dfn get all exams within date range
@@ -60,13 +60,9 @@
  ...S ECXW=$P(ECCA,U,6),ECXW=$P($G(^DIC(42,+ECXW,44)),U)
  ...S:ECXW="" ECXW=$P(ECCA,U,8)
- ...S ECDOCNPI=$$NPI^XUSNPI("Individual_ID",$P(ECCA,U,14),ECDT)
- ...S:+ECDOCNPI'>0 ECDOCNPI="" S ECDOCNPI=$P(ECDOCNPI,U)
  ...S (ECXDSSD,ECXDSSP)=""
- ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT)
+ ...S ECS=$P(ECCA,U,7),ECDOC=ECPROF_$P(ECCA,U,14),ECDOCNPI="",ECDI=$P(ECCA,U,13),ECDOCPC=$$PRVCLASS^ECXUTL($P(ECCA,U,14),ECDT)
  ...S ECPRO=$P(ECCA,U,2),ECSTAT=$P($G(^RA(72,+$P(ECCA,U,3),0)),U,3)
  ...;get the primary interpreting staff and the person class DBIA #65
  ...S ECXIS=$P(ECCA,U,15),ECXISPC=$$PRVCLASS^ECXUTL(ECXIS,ECDT)
- ...S ECISNPI=$$NPI^XUSNPI("Individual_ID",ECXIS,ECDT)
- ...S:+ECISNPI'>0 ECISNPI="" S ECISNPI=$P(ECISNPI,U)
  ...;prefix interpreting radiologist with a "2" if not null
  ...S ECXIS=$S(ECXIS:"2"_ECXIS,1:"")
@@ -104,11 +100,11 @@
  ;imaging type^primary care team^primary care provider
  ;node1
- ;mpi^dss dept^placeholder^placeholder^pc prov person class^
- ;assoc pc provider^assoc pc prov person class^placeholder^dom^
+ ;mpi^dss dept^req physician npi^pc provider npi^pc prov person class^
+ ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^dom^
  ;observ pat ind^encounter num^ord stop code^ord date^division^
  ;dss product ECXDSSP^requesting provider person class ECDOCPC^interp-
  ;reting radiologist ECXIS^interpreting radiologist pc ECXISPC^princi-
  ;pal clinic ECXPRCL^clinc stop code ECXCSC^emergency response indicator
- ;(FEMA) ECXERI^assoc pc provider npi^interpreting rad npi^pc provider npi^req physician npi
+ ;(FEMA) ECXERI
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -117,11 +113,10 @@
  S ECODE=ECODE_ECDOC_U_ECMODS_U_ECXMN_U_ECXTS_U_ECTM_U_ECTY_U_ECPTTM_U
  S ECODE=ECODE_ECPTPR_U
- S ECODE1=ECXMPI_U_ECXDSSD_U_U_U_ECCLAS_U_ECASPR_U
- S ECODE1=ECODE1_ECCLAS2_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECDOCNPI_U_ECPTNPI_U_ECCLAS_U_ECASPR_U
+ S ECODE1=ECODE1_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXORDST_U
  S ECODE1=ECODE1_ECXORDDT_U_ECXPDIV_U
  I ECXLOGIC>2004 S ECODE1=ECODE1_ECXDSSP_U_ECDOCPC
  I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXIS_U_ECXISPC_U_ECXPRCL_U_ECXCSC
  I ECXLOGIC>2006 S ECODE1=ECODE1_U_ECXERI
- I ECXLOGIC>2007 S ECODE1=ECODE1_U_ECASNPI_U_ECISNPI_U_ECPTNPI_U_ECDOCNPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
  S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCLD.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSCLD.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCLD.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 5/24/07 3:49pm
- ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105**;Dec 22, 1997;Build 70
+ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ; 9/21/04 7:33am
+ ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80**;Dec 22, 1997
 EN ;entry point from option
  ;load entries
@@ -60,11 +60,11 @@
  E  W !,"(NEVER REVIEWED)"
  W !
- W !!,?1,"CLINIC",?31,"STOP",?38,"CREDIT",?47,"DSS",?54,"DSS",?63,"ACTION",?71,"NAT'L"
- W !,?31,"CODE",?38,"STOP",?47,"STOP",?54,"CREDIT",?71,"CODE",!,?1,"(* - currently inactive)",?38,"CODE",?47,"CODE",?54,"CODE",!,LN Q
+ W !!,?1,"CLINIC",?27,"STOP",?34,"CREDIT",?43,"DSS",?50,"DSS",?59,"ACTION",?67,"NAT'L",?74,"DSS"
+ W !,?27,"CODE",?34,"STOP",?43,"STOP",?50,"CREDIT",?67,"CODE",?74,"DEPT",!,?1,"(* - currently inactive)",?34,"CODE",?43,"CODE",?50,"CODE",!,LN Q
  ;
 SHOWEM ; list clinics for worksheet
  I $Y+4>IOSL D HEAD Q:QFLG
- W !!,$E(ECSC,1,31) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("31,38,47,54,66",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____")
- S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?71,$S(ECN]"":ECN,1:"____")
+ W !!,$E(ECSC,1,25) W:$P(ECD,U,9)]"" "*" F J=1:1:5 W ?$P("27,34,43,50,62",",",J),$S($P(ECD,U,J):$P(ECD,U,J),J<3:"",1:"_____")
+ S ECN=$P($G(^ECX(728.441,+$P(ECD,U,7),0)),U) W ?67,$S(ECN]"":ECN,1:"____"),?74,$S($P(ECD,U,10)'="":$P(ECD,U,10),1:"___")
  Q
 SS ;SCROLL STOPS
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCX1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSCX1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCX1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 4/11/07 3:26pm
- ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92,105**;Dec 22, 1997;Build 70
+ECXSCX1 ;ALB/JAP,BIR/DMA-Clinic Extract Message ; 8/17/06 7:59am
+ ;;3.0;DSS EXTRACTS;**8,28,24,27,29,30,31,33,84,92**;Dec 22, 1997;Build 30
 EN ;entry point from ecxscx
  N ECX
@@ -148,4 +148,5 @@
  .I '$D(ARY("P",ICD("S",I))) D
  ..S CNT=CNT+1,ECXVIST("ICD9"_CNT)=$P($G(^ICD9(ICD("S",I),0)),U)
+ S:(ECXVIST("ICD9P")="")&(ECXVIST("ICD91")="") ECXVIST("ICD9P")="799.9"
  ;get first provider designated as primary
  ;if no primary, then get first physician provider
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCX2.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSCX2.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCX2.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXSCX2 ;ALB/ESD  DSS Clinic Extract Utilities (continued) ; 6/5/2007
- ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92,105**;Dec 22, 1997;Build 70
+ECXSCX2 ;ALB/ESD  DSS Clinic Extract Utilities (continued) ; 11/2/06 8:59am
+ ;;3.0;DSS EXTRACTS;**39,46,49,71,84,92**;Dec 22, 1997;Build 30
  ;
  ;
@@ -27,7 +27,4 @@
  ;- Agent Orange location
  S ECXAOL=ECXPAT("AOL")
- ;OEF/OIF data
- S ECXOEF=ECXPAT("ECXOEF")
- S ECXOEFDT=ECXPAT("ECXOEFDT")
  I $$ENROLLM^ECXUTL2(ECXDFN)
  ; - Head and Neck Cancer Indicator
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCXN.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSCXN.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCXN.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXSCXN ;ALB/JAP  Clinic Extract ; 6/5/07 11:55am
- ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107,105**;Dec 22, 1997;Build 70
+ECXSCXN ;ALB/JAP  Clinic Extract ; 4/19/2007
+ ;;3.0;DSS EXTRACTS;**24,27,29,30,31,32,33,39,46,49,52,71,84,92,107**;Dec 22, 1997;Build 9
  ;
 BEG ;entry point from option
@@ -77,6 +77,4 @@
  ..S SOURCE=ECXVIST("SOURCE"),ECXAO=ECXVIST("AO"),ECXIR=ECXVIST("IR")
  ..S ECXMIL=ECXVIST("MST"),ECXPROV=ECXVIST("PROV")
- ..S ECPRNPI=$$NPI^XUSNPI("Individual_ID",ECXPROV,ECXDATE)
- ..S:+ECPRNPI'>0 ECPRNPI="" S ECPRNPI=$P(ECPRNPI,U)
  ..S ECXPROVP=ECXVIST("PROV CLASS"),ECXPROVN=ECXVIST("PROV NPI")
  ..S ECXECE=ECXVIST("PGE"),ECXHNC=ECXVIST("HNC")
@@ -140,7 +138,7 @@
  S STR(1)=STR(1)_ECXRACE_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXIR_U_ECXAST_U
  S STR(1)=STR(1)_ECXAO_U_ECXMPI_U_ECXDSSD_U_ECXSEX_U_ECXZIP_U
- S STR(1)=STR(1)_$G(ECXPCPNP)_U_U_ECXENEL_U_ECXMST_U
+ S STR(1)=STR(1)_$G(ECXPCPNP)_U_$G(ECXNPIPR)_U_ECXENEL_U_ECXMST_U
  S STR(1)=STR(1)_ECXMIL_U_U_U_ECXENRL_U_ECXSTATE_U
- S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_U_ECXDOM_U_ECXCAT_U
+ S STR(1)=STR(1)_ECXCNTY_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXDOM_U_ECXCAT_U
  S STR(2)=ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPHI_U_ECXPOS_U_ECXOBS_U_ECXENC_U
  S STR(2)=STR(2)_ECXAOL_U_ECXPDIV_U_ECXATYP_U_ECXPVST_U_ECXMTST_U
@@ -150,5 +148,4 @@
  I ECXLOGIC>2005 S STR(2)=STR(2)_U_ECXEST_U_ECXECE
  I ECXLOGIC>2006 S STR(2)=STR(2)_U_ECXERI_U_ECXHNC
- I ECXLOGIC>2007 S STR(2)=STR(2)_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_$G(ECPRNPI)
  D FILE2^ECXSCX2(727.827,EC7,.STR)
  S ECRN=ECRN+1,$P(^ECX(727.827,0),U,3)=EC7
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCXN1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSCXN1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSCXN1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXSCXN1 ;ALB/JAP  Clinic Extract No Shows; 8/28/02 1:11pm ; 9/6/07 3:17pm
- ;;3.0;DSS EXTRACTS;**71,105**;Dec 22, 1997;Build 70
+ECXSCXN1 ;ALB/JAP  Clinic Extract No Shows; 8/28/02 1:11pm ; 10/26/04 10:35am
+ ;;3.0;DSS EXTRACTS;**71**;Dec 22, 1997
 NOSHOW(ECXSD,ECXED) ;get noshows from file #44
  ;      ECXSD  = start date, ECXED  = end date
@@ -31,5 +31,5 @@
  ....S ECXPVST=$P(NODE,U,7),ECXATYP=$P(NODE,U,16)  ;Get POV & appt type
  ....S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2)
- ....S ECXCLIN=CLIN,ECXSTOP=P1
+ ....S ECXCLIN=CLIN,ECXSTOP=P1 S:ECXICD9P="" ECXICD9P="799.9"
  ....S:ECXCPT1="" ECXCPT1="9919901"
  ....S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSURG.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXSURG.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXSURG.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/20/07 8:13am
- ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99,105**;Dec 22, 1997;Build 70
+ECXSURG ;ALB/JA,BIR/DMA,PTD-Surgery Extract for DSS ; 11/2/06 9:00am
+ ;;3.0;DSS EXTRACTS;**1,11,8,13,25,24,33,39,41,42,46,50,71,84,92,99**;Dec 22, 1997;Build 2
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -16,23 +16,16 @@
  N J,X,Y,PP,DATA1,DATA2,DATAOP,ARR,ERR,SUB,MOD,ECXNONL,ECXSTOP,TIMEDIF
  N ECPRO,ECXORCT,ECXPTHA,ECXNPRFI,ECXPA,ECXPAPC,ECSRPC,ECATPC,ECSAPC
- N ECXCRST,ECXSTCD,ECXCLIN
  S ECXDATE=ECD,ECXERR=0,ECXQ=""
  Q:'$$PATDEM^ECXUTL2(ECXDFN,ECXDATE,"1;2;3;5;")
  I ECXADMDT="" S ECXADD=ECXADMDT
  I ECXADMDT'="" S ECXADD=$$ECXDATE^ECXUTL(ECXADMDT,ECXYM)
- S OK=$$PAT^ECXUTL3(ECXDFN,ECXDATE,"1;5",.ECXPAT)
- I 'OK S ECXERR=1 K ECXPAT Q
- ;OEF/OIF DATA
- S ECXOEF=ECXPAT("ECXOEF")
- S ECXOEFDT=ECXPAT("ECXOEFDT")
  S EC0=^SRF(ECD0,0)
  S DATA1=$S($D(^SRF(ECD0,.1)):^(.1),1:"")
  S DATA2=$S($D(^SRF(ECD0,.2)):^(.2),1:"")
+ ;S DATAOP=$S($D(^SRF(ECD0,"OP")):^("OP"),1:"")
  S DATAOP=$S($D(^SRO(136,ECD0,0)):^(0),1:"")
  S ECNO=$G(^SRF(ECD0,"NON"))
  ;get data
  S ECSR=$P(DATA1,U,4),(ECATNPI,ECSANPI,ECSRNPI)="",ECAT=$P(DATA1,U,13)
- S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE)
- S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U)
  ;-Time patient in OR room (Nurse Time)
  S ECXTM=$$ECXTIME^ECXUTL($P(DATA2,U,10))
@@ -40,10 +33,6 @@
  N ECXPDIV S ECXPDIV=$$RADDIV^ECXDEPT(ECXDIV)  ;Production Division
  S ECSA=$P($G(^SRF(ECD0,.3)),U,4),ECO=$P(EC0,U,2)
- S ECSANPI=$$NPI^XUSNPI("Individual_ID",ECSA,ECXDATE)
- S:+ECSANPI'>0 ECSANPI="" S ECSANPI=$P(ECSANPI,U)
  ;get principle anesthetist and person class DBIA #103
  S ECXPA=$P($G(^SRF(ECD0,.3)),U,1)
- S ECPANPI=$$NPI^XUSNPI("Individual_ID",ECXPA,ECXDATE)
- S:+ECPANPI'>0 ECPANPI="" S ECPANPI=$P(ECPANPI,U)
  S ECXPAPC=$$PRVCLASS^ECXUTL(ECXPA,ECXDATE)
  S ECORTY=$P($G(^SRS(+ECO,2)),U),ECO=$P($G(^SRS(+ECO,0)),U)
@@ -61,8 +50,4 @@
  I $P(ECNO,U)="Y" D
  .S ECSR=$P(ECNO,U,6),ECAT=$P(ECNO,U,7)
- .S ECSRNPI=$$NPI^XUSNPI("Individual_ID",ECSR,ECXDATE)
- .S:+ECSRNPI'>0 ECSRNPI="" S ECSRNPI=$P(ECSRNPI,U)
- .S ECATNPI=$$NPI^XUSNPI("Individual_ID",ECAT,ECXDATE)
- .S:+ECATNPI'>0 ECATNPI="" S ECATNPI=$P(ECATNPI,U)
  .S ECXTM=$$ECXTIME^ECXUTL($P(ECNO,U,4))
  .S A1=$P(ECNO,U,5),A2=$P(ECNO,U,4),TIME="##" D:(A1&A2) TIME S ECNT=TIME
@@ -72,7 +57,4 @@
  .;- Get DSS Stop Code to use in encounter number
  .S ECXSTOP=$P($G(^ECX(728.44,ECXNONL,0)),U,4)
- ;
- ;- Get credit stop, stop code and clinic
- I $$SUR^ECXUTL6(.ECXCRST,.ECXSTCD,.ECXCLIN)
  ;
  ;- If surgery cancelled/aborted quit and go to next record
@@ -154,15 +136,12 @@
  S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
  ;
- ;- Get postop diagnosis codes
- I $$SURPODX^ECXUTL6(.ECXPODX,.ECXPODX1,.ECXPODX2,.ECXPODX3,.ECXPODX4,.ECXPODX5)
- ;
- D FILE^ECXSURG1
+ D FILE
  ;get secondary procedures
  ;ecode0=s^cpt code
  S ECXJ=0
+ ;F  S ECXJ=$O(^SRF(ECD0,13,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)),$D(^(2)),$P(^(2),U)]"" D
  F  S ECXJ=$O(^SRO(136,ECD0,3,ECXJ)) Q:'ECXJ  I $D(^(ECXJ,0)),$D(^(0)),$P(^(0),"^")]"" D
  .;S ECPT=$P(^SRF(ECD0,13,ECXJ,2),U),ECXCMOD=""
- .S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),U),ECXMOD=""
- .S ECPT=$P(^(0),"^"),ECXCMOD=""
+ . S ECPT=$P(^SRO(136,ECD0,3,ECXJ,0),"^"),ECXCMOD=""
  .K ARR,ERR
  .D FIELD^DID(130.16,4,,"LABEL","ARR","ERR") I $D(ARR("LABEL")) D
@@ -174,5 +153,5 @@
  .S ECXCPT=$$CPT^ECXUTL3(ECPT,ECXCMOD)
  .S ECODE0="S"_U   ;_ECPT
- .D FILE^ECXSURG1
+ .D FILE
  ;get prostheses
  ;ecode0=i^^^^^^prosthesis^old qty field (null)
@@ -181,7 +160,55 @@
  .S ECXP=+^SRF(ECD0,1,ECXJ,0),ECXQ=$P($G(^(1)),U,2) S:'ECXQ ECXQ=1
  .S ECODE0="I"_U_U_U_U_U_U_ECXP_U_U
- .D FILE^ECXSURG1
- Q
- ;
+ .D FILE
+ Q
+ ;
+FILE ;file record
+ ;node0
+ ;division^dfn^ssn^name^in/out (ECXA)^day^case #^
+ ;surg specialty^or room #^
+ ;surgeon^attending^anesthesia supervisor^anesthesia technique^
+ ;primary/secondary/prostheses^cpt^^pt time^op time^anes time^
+ ;prostheses^qty^^
+ ;movement number^treating specialty^cancel/abort (ECCAN)^time^or type^
+ ;attending's service^non-or dss id^recovery room time^^
+ ;primary care team^primary care provider^admission date
+ ;node1
+ ;mpi^dss dept ECXDSSD^surgeon npi^attending npi^anes supervisor npi^
+ ;pc provider npi^pc prov person class^
+ ;assoc pc provider^assoc pc prov person class^assoc pc prov npi^
+ ;cpt&modifiers ECXCPT^dom ECXDOM^enrollment category ECXCAT^
+ ;enrollment status ECXSTAT^enrollment priority ECXPRIOR^
+ ;period of service ECXPOS^purple heart indicator ECXPHI^
+ ;observ pat ind ECXOBS^encounter num ECXENC^ao loc ECXAOL^
+ ;production division ECXPDIV^head & neck canc ind ECXHNCI^
+ ;ethnicity ECXETH^race1 ECXRC1^new quantity ECXQ^
+ ;^user enrollee ECXUESTA^patient type ECXPTYPE^combat vet elig
+ ;ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible ECXCVENC
+ ;or clean time ECXORCT^time pt in hold area ECXPTHA^national patient
+ ;record flag ECXNPRFI^princ anesthetist ECXPA^surgeon per class ECSRPC
+ ;node2
+ ;atten surgeon per class ECATPC^anesthesia super person class ECSAPC^
+ ;princ anesthetist PC ECXPAPC^emergency response indicator(FEMA) ECXERI^
+ ;agent orange indic ECXAO^head/neck cancer ECXHNC
+ ;
+ N DA,DIK,STR
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_ECXDIV_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U
+ S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXDATE,ECXYM)_U_ECD0_U_ECSS_U_ECO_U
+ S ECODE=ECODE_ECSR_U_ECAT_U_ECSA_U_ECANE_U_ECODE0_U
+ S STR=ECXMN_U_ECXTS_U_$S(ECCAN'="":ECCAN,1:"")_U_ECXTM_U_ECORTY_U
+ S STR=STR_ECATSV_U_ECNL_U_ECRR_U_U_ECPTTM_U_ECPTPR_U_ECXADD_U
+ S $P(ECODE,U,26,38)=STR
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECSRNPI_U_ECATNPI_U_ECSANPI_U_ECPTNPI_U
+ S ECODE1=ECODE1_ECCLAS_U_ECASPR_U_ECCLAS2_U_ECASNPI_U_ECXCPT_U_ECXDOM_U
+ S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECXPOS_U_ECXPHI_U
+ S ECODE1=ECODE1_ECXOBS_U_ECXENC_U_ECXAOL_U_ECXPDIV_U_ECXHNCI_U
+ S ECODE1=ECODE1_ECXETH_U_ECXRC1_U_ECXQ_U
+ I ECXLOGIC>2004 S ECODE1=ECODE1_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXORCT_U_ECXPTHA_U_ECXNPRFI
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXPA_U_ECSRPC_U,ECODE2=ECATPC_U_ECSAPC_U_ECXPAPC
+ I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXAO_U_ECXHNC
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
  ;
 TIME ; given date/time get increment
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXTRAC.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXTRAC.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXTRAC.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 7/29/07 12:51pm
- ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84,105**;Dec 22, 1997;Build 70
+ECXTRAC ;ALB/GTS,JAP,BIR/DMA,CML-Package Extracts for DSS ; 5/9/05 10:39am
+ ;;3.0;DSS EXTRACTS;**9,8,14,24,30,33,49,84**;Dec 22, 1997
  ;Date range, queuing and message sending for package extracts
  ;Input
@@ -184,12 +184,10 @@
 CHK2 ;iv extract check - all active iv rooms to have a division
  S EC=0
- D ALL^PSJ59P5(,"??","ECXIV")
- F  S EC=$O(^TMP($J,"ECXIV",EC)) Q:'EC  I '^(EC,19) D  I CHKFLG D EXIT Q
- .S CHKFLG=$S($G(^TMP($J,"ECXIV",EC,19)):1,$G(^(19))>DT:1,1:0)
+ F  S EC=$O(^PS(59.5,EC)) Q:'EC  I '$P(^PS(59.5,EC,0),U,4) D  Q:CHKFLG
+ .S CHKFLG=$S('$G(^PS(59.5,EC,"I")):1,$G(^PS(59.5,EC,"I"))>DT:1,1:0)
  .I CHKFLG D
  ..W !!,"All active IV Rooms in the IV Room file (#59.5) must have a ""DIVISION""",!,"assigned to run this extract!"
  ..W !!,"This information can be entered using the DSS Extract Manager's Maintenance ",!,"option ""Enter/Edit IV Room Division""."
  ..D PAUSE
-EXIT K ^TMP($J,"ECXIV")
  Q
  ;
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXTREX.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXTREX.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXTREX.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 6/11/07 12:46pm
- ;;3.0;DSS EXTRACTS;**49,71,84,92,105**;Dec 22, 1997;Build 70
+ECXTREX ;BPFO/JRP - Queue DSS Fiscal Year Specific Extract;8-AUG-2003 ; 11/2/06 9:02am
+ ;;3.0;DSS EXTRACTS;**49,71,84,92**;Dec 22, 1997;Build 30
  ;
 EN ;Main entry point
@@ -71,5 +71,5 @@
  S DIR("A")="Select fiscal year logic to use for extract"
  S DIR(0)="SO^"
- F X=2003,2004,2005,2006,2007,2008 D
+ F X=2003,2004,2005,2006,2007 D
  .S Y=$E(X,5)
  .S Y=$S((Y="")!(Y=" "):"",1:"Revision "_Y_" of ")
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXTRT.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXTRT.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXTRT.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 10/17/07 3:48pm
- ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107,105**;Dec 22, 1997;Build 70
+ECXTRT ;ALB/JAP,BIR/DMA,CML,PTD-Treating Specialty Change Extract ; 04/12/2007
+ ;;3.0;DSS EXTRACTS;**1,8,17,24,33,35,39,46,49,84,107**;Dec 22, 1997;Build 9
 BEG ;entry point from option
  D SETUP I ECFILE="" Q
@@ -37,8 +37,8 @@
  ..D:ECXTRTL'=ECXTRTN PREVTRT^ECXTRT1(.LOC,ECD1,ECD2,ECXTRTL,.ECXLOS)
  ..;whether ts has changed or not, see if primary provider has changed
- ..;don't bother if there's no data on current primary provider or no change in provider
+ ..;dont bother if there's no data on current primary provider or no change in provider
  ..D:(ECXPRVN'="")&(ECXPRVN'=ECXPRVL) PREVPRV^ECXTRT1(.LOC,ECD1,ECXPRVN,ECD2,.ECXPRVL,.ECXLOSP)
  ..;whether ts has changed or not, see if attending physician has changed
- ..;don't bother if there's no data on current attending physician or no change in attending
+ ..;dont bother if theres no data on current attending physician or no change in attending
  ..D:(ECXATTN'="")&(ECXATTN'=ECXATTL) PREVATT^ECXTRT1(.LOC,ECD1,ECXATTN,ECD2,.ECXATTL,.ECXLOSA)
  ..S ECXDATE=$$ECXDATE^ECXUTL(ECXMVD1,ECXYM),ECXTIME=$$ECXTIME^ECXUTL(ECXMVD1)
@@ -47,4 +47,5 @@
  ..S ECXPDIV=""
  ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
+ ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)=""
  ..;
  ..;- Observation patient indicator (YES/NO)
@@ -56,22 +57,14 @@
  ..;- Get providers person classes
  .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
- .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
- .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
  .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
- .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
- .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
  .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
- .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
- .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
  .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
- .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
- .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
  ..;
  ..;- If no encounter number, don't file record
  ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
- ..D:ECXENC'="" FILE^ECXTRT2
+ ..D:ECXENC'="" FILE
  ;for nhcu episodes with intervening asih stays, the los calculated here is not accurate,
  ;but it never has been; this is best solution within current extract framework;
- ;at discharge the los calculated for nhcu episodes will be the los since admission w/o asih los subtracted;
+ ;at discharge the los calculated for nhcu apisodes will be the los since admission w/o asih los subtracted;
  ;
  ;loop through discharges to get last treating specialty
@@ -109,4 +102,5 @@
  ..S ECXPDIV=""
  ..I ECXLOGIC>2003 S ECXPDIV=$S(WRD="":"",1:$$NPDIV(WRD))
+ ..S (ECXALNPI,ECXANNPI,ECXPLNPI,ECXPNNPI)=""
  ..;
  ..;- Observation patient indicator (YES/NO)
@@ -118,19 +112,11 @@
  ..;- Get providers person classes
  .. S ECXATLPC=$$PRVCLASS^ECXUTL($E(ECXATTL,2,999),ECXADT)
- .. S ECATLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTL,2,999),ECXADT)
- .. S:+ECATLNPI'>0 ECATLNPI="" S ECATLNPI=$P(ECATLNPI,U)
  .. S ECXPRNPC=$$PRVCLASS^ECXUTL($E(ECXPRVN,2,999),ECXADT)
- .. S ECPRVNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVN,2,999),ECXADT)
- .. S:+ECPRVNPI'>0 ECPRVNPI="" S ECPRVNPI=$P(ECPRVNPI,U)
  .. S ECXATNPC=$$PRVCLASS^ECXUTL($E(ECXATTN,2,999),ECXADT)
- .. S ECATTNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXATTN,2,999),ECXADT)
- .. S:+ECATTNPI'>0 ECATTNPI="" S ECATTNPI=$P(ECATTNPI,U)
  .. S ECXPRLPC=$$PRVCLASS^ECXUTL($E(ECXPRVL,2,999),ECXADT)
- .. S ECPRLNPI=$$NPI^XUSNPI("Individual_ID",$E(ECXPRVL,2,999),ECXADT)
- .. S:+ECPRLNPI'>0 ECPRLNPI="" S ECPRLNPI=$P(ECPRLNPI,U)
  ..;
  ..;- If no encounter number don't file record
  ..S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADT,,ECXTS,ECXOBS,ECHEAD,,)
- ..D:ECXENC'="" FILE^ECXTRT2
+ ..D:ECXENC'="" FILE
  D KPATDEM^ECXUTL2
  Q
@@ -178,4 +164,36 @@
  Q
  ;
+FILE ;file the extract record
+ ;node0
+ ;^dfn^ssn^name^i/o (ECXA)^date^product^adm date^d/c date^
+ ;mov#^type^new ts^losing ts^losing ts los^
+ ;losing attending^movement type^time^adm time^new provider^
+ ;new attending^losing provider
+ ;node1
+ ;mpi^dss dept^losing attending npi^new provider npi^new attending npi^
+ ;losing provider npi^losing attending los^losing provider los^dom^
+ ;observ pat ind^encounter num
+ ;
+ ;convert specialties to PTF Codes for transmission
+ ;
+ N ECXDATA
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCN,.ECXDATA)
+ S ECXSPCN=$G(ECXDATA(7))
+ S ECXDATA=$$TSDATA^DGACT(42.4,+ECXSPCL,.ECXDATA)
+ S ECXSPCL=$G(ECXDATA(7))
+ ;done
+ S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
+ S ECODE=EC7_U_EC23_U_U_ECXDFN_U_ECXSSN_U_ECXPNM_U_ECXA_U_ECXDATE_U_U
+ S ECODE=ECODE_ECXADMDT_U_ECXDCDT_U_ECDA_U_6_U_ECXSPCN_U_ECXSPCL_U
+ S ECODE=ECODE_ECXLOS_U_ECXATTL_U_ECMT_U_ECXTIME_U_ECXADMTM_U_ECXPRVN_U
+ S ECODE=ECODE_ECXATTN_U_ECXPRVL_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXALNPI_U_ECXPNNPI_U_ECXANNPI_U_ECXPLNPI_U
+ S ECODE1=ECODE1_ECXLOSA_U_ECXLOSP_U_ECXDOM_U_ECXOBS_U_ECXENC_U_ECXPDIV
+ I ECXLOGIC>2005 S ECODE1=ECODE1_U_ECXATLPC_U_ECXPRNPC_U_ECXATNPC_U_ECXPRLPC
+ S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1,ECRN=ECRN+1
+ S DA=EC7,DIK="^ECX("_ECFILE_"," D IX1^DIK K DIK,DA
+ I $D(ZTQUEUED),$$S^%ZTLOAD S QFLG=1
+ Q
+ ;
 SETUP ;Set required input for ECXTRAC
  S ECHEAD="TRT"
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUD.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUD.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUD.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ; 10/31/07 1:58pm
- ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107,105**;Dec 22, 1997;Build 70
+ECXUD ;ALB/JAP,BIR/DMA,PTD-Extract from UNIT DOSE EXTRACT DATA File (#728.904) ;4/19/2007
+ ;;3.0;DSS EXTRACTS;**10,8,24,33,39,46,49,71,84,92,107**;Dec 22, 1997;Build 9
 BEG ;entry point from option
  I '$O(^ECX(728.904,"A",0)) W !,"There are no unit dose orders to extract",!! R X:5 K X Q
@@ -24,8 +24,6 @@
  Q:ECXERR
  ;
- S ECXPRO=$P(DATA,U,7),ECPROIEN=+ECXPRO,ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";")
- S ECXPRNPI=$$NPI^XUSNPI("Individual_ID",ECPROIEN,ECD)
- S:+ECXPRNPI'>0 ECXPRNPI="" S ECXPRNPI=$P(ECXPRNPI,U)
- S W=$P(DATA,U,6)
+ S ECXPRO=$P(DATA,U,7),ECXPRO=$E($P(ECXPRO,";",2))_$P(ECXPRO,";")
+ S ECXPRNPI="",W=$P(DATA,U,6)
  S ECXDIV=$P($G(^DIC(42,+W,0)),U,11),ECXW=$P($G(^DIC(42,+W,44)),U)
  S ECXUDDT=$$ECXDATE^ECXUTL($P(DATA,U,3),ECXYM)
@@ -65,5 +63,5 @@
 PAT(ECXDFN,ECXDATE,ECXERR) ;get demographics from patient file
  ;init variables
- S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP,ECXOEF,ECXOEFDT)=""
+ S (ECXCAT,ECXSTAT,ECXPRIOR,ECXSBGRP)=""
  ;get patient data if saved
  I $D(^TMP($J,"ECXP",ECXDFN)) D
@@ -78,5 +76,5 @@
  .S ECXSTAT=$P(PT,U,22),ECXPRIOR=$P(PT,U,23),ECXHNCI=$P(PT,U,24)
  .S ECXETH=$P(PT,U,25),ECXRC1=$P(PT,U,26),ECXMTST=$P(PT,U,27)
- .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2),ECXOEF=$P(PT1,U,3),ECXOEFDT=$P(PT1,U,4)
+ .S PT1=$G(^TMP($J,"ECXP",ECXDFN,1)),ECXERI=$P(PT1,U),ECXEST=$P(PT1,U,2)
  .I $$ENROLLM^ECXUTL2(ECXDFN)
  ;set patient data
@@ -93,7 +91,4 @@
  .S ECXPHI=ECXPAT("PHI"),ECXMST=ECXPAT("MST STAT")
  .S ECXENRL=ECXPAT("ENROLL LOC"),ECXMTST=ECXPAT("MEANS")
- .;OEF/OIF data
- .S ECXOEF=ECXPAT("ECXOEF")
- .S ECXOEFDT=ECXPAT("ECXOEFDT")
  .;get CNHU status
  .S ECXCNHU=$$CNHSTAT^ECXUTL4(ECXDFN)
@@ -111,5 +106,5 @@
  .S ^TMP($J,"ECXP",ECXDFN)=ECXPNM_U_ECXSSN_U_ECXMPI_U_ECXDOB_U_ECXELIG_U_ECXSEX_U_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U_ECXPST_U_ECXPLOC_U_ECXRST_U_ECXAST
  .S ^TMP($J,"ECXP",ECXDFN)=^TMP($J,"ECXP",ECXDFN)_U_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXENRL_U_ECXCNHU_U_ECXCAT_U_ECXSTAT_U_ECXPRIOR_U_ECXHNCI_U_ECXETH_U_ECXRC1_U_ECXMTST
- .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST_U_ECXOEF_U_ECXOEFDT
+ .S ^TMP($J,"ECXP",ECXDFN,1)=ECXERI_U_ECXEST
  ;
  ;get inpatient data
@@ -144,5 +139,5 @@
  ;elig ECXCVE^combat vet elig end date ECXCVEDT^enc cv eligible
  ;ECXCVENC^national patient record flag ECXNPRFI^emerg resp indic(FEMA) 
- ;ECXERI^environ contamin ECXEST^OEF/OIF ECXOEF^OEF/OIF return date ECXOEFDT^associate pc provider npi ECASNPI^primary care provider npi ECPTNPI^provider npi ECXPRNPI
+ ;ECXERI^environ contamin ECXEST
  N DA,DIK
  S EC7=$O(^ECX(ECFILE,999999999),-1),EC7=EC7+1
@@ -157,5 +152,5 @@
  S ECODE=ECODE_$$ECXDATE^ECXUTL(ECXADM,ECXYM)_U
  S ECODE=ECODE_$$ECXTIME^ECXUTL(ECXADM)_U
- S ECODE1=ECXMPI_U_ECXDSSD_U_U_ECXDOM_U_ECXOBS_U_ECXENC_U
+ S ECODE1=ECXMPI_U_ECXDSSD_U_ECXPRNPI_U_ECXDOM_U_ECXOBS_U_ECXENC_U
  S ECODE1=ECODE1_ECXPDIV_U_ECXMTST_U_ECXELIG_U_ECXDOB_U_ECXSEX_U
  S ECODE1=ECODE1_ECXSTATE_U_ECXCNTY_U_ECXZIP_U_ECXVET_U_ECXPOS_U
@@ -163,10 +158,9 @@
  S ECODE1=ECODE1_ECXAOL_U_ECXPHI_U_ECXMST_U_ECXCNHU_U_ECXENRL_U
  S ECODE1=ECODE1_ECXCAT_U_ECXSTAT_U_$S(ECXLOGIC<2005:ECXPRIOR,1:"")_U_ECPTTM_U_ECPTPR_U
- S ECODE1=ECODE1_U_ECCLAS_U_ECASPR_U_U_ECCLAS2_U
+ S ECODE1=ECODE1_ECPTNPI_U_ECCLAS_U_ECASPR_U_ECASNPI_U_ECCLAS2_U
  S ECODE2=ECXORDDT_U_ECXORDST_U_ECXHNCI_U_ECXETH_U_ECXRC1
  I ECXLOGIC>2003 S ECODE2=ECODE2_U_ECXBCDD_U_ECXBCDG_U_ECXBCUA_U_ECXBCIF_U_ECXOPPC
  I ECXLOGIC>2004 S ECODE2=ECODE2_U_U_ECXPRIOR_ECXSBGRP_U_ECXUESTA_U_ECXPTYPE_U_ECXCVE_U_ECXCVEDT_U_ECXCVENC_U_ECXNPRFI
  I ECXLOGIC>2006 S ECODE2=ECODE2_U_ECXERI_U_ECXEST
- I ECXLOGIC>2007 S ECODE2=ECODE2_U_ECXOEF_U_ECXOEFDT_U_ECASNPI_U_ECPTNPI_U_ECXPRNPI
  S ^ECX(ECFILE,EC7,0)=ECODE,^ECX(ECFILE,EC7,1)=ECODE1
  S ^ECX(ECFILE,EC7,2)=ECODE2,ECRN=ECRN+1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUPRO.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUPRO.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 1/08/08 1:00pm
- ;;3.0;DSS EXTRACTS;**49,111**;July 1, 2003;Build 4
+ECXUPRO ;ALB/TJL-Prosthetic Extract Unusual Cost Report ; 7/1/03 1:00pm
+ ;;3.0;DSS EXTRACTS;**49**;July 1, 2003
  ;
 EN ; entry point
@@ -77,5 +77,5 @@
  ;
 PRINT ; process temp file and print report
- N PG,QFLG,GTOT,LN,COUNT,FKEY,COST,SSN,REC,SDAY
+ N PG,QFLG,GTOT,LN,COUNT,FKEY,COST,SSN,REC
  U IO
  I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ Q
@@ -85,9 +85,8 @@
  F  S FKEY=$O(^TMP($J,FKEY)) Q:FKEY=""!QFLG  D
  .S COST="" F  S COST=$O(^TMP($J,FKEY,COST)) Q:COST=""!QFLG  D
- .. S SDAY="" F  S SDAY=$O(^TMP($J,FKEY,COST,SDAY)) Q:SDAY=""!QFLG  D
- ...S SSN="" F  S SSN=$O(^TMP($J,FKEY,COST,SDAY,SSN)) Q:SSN=""!QFLG  S REC=^(SSN)  D
- ....S COUNT=COUNT+1
- ....I $Y+3>IOSL D HEADER Q:QFLG
- ....W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11)
+ ..S SSN="" F  S SSN=$O(^TMP($J,FKEY,COST,SSN)) Q:SSN=""!QFLG  S REC=^(SSN)  D
+ ...S COUNT=COUNT+1
+ ...I $Y+3>IOSL D HEADER Q:QFLG
+ ...W !,$P(REC,U),?8,$P(REC,U,2),?21,$P(REC,U,3),?39,$P(REC,U,4),?70,$P(REC,U,5),?93,$$RJ^XLFSTR($P(REC,U,6),8),?110,$$RJ^XLFSTR($P(REC,U,7),11)
  Q:QFLG
  I COUNT=0 W !!,?8,"No unusual costs to report for this extract"
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUPRO1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUPRO1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUPRO1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 01/08/08 2:49pm
- ;;3.0;DSS EXTRACTS;**49,111**;Jul 2, 2003;Build 4
+ECXUPRO1 ;ALB/TJL-Prosthetics Extract Unusual Cost Report; 7/2/03 2:49pm
+ ;;3.0;DSS EXTRACTS;**49**;Jul 2, 2003
  ;
 EN ; entry point
@@ -48,5 +48,5 @@
  S:(+PROQTY=0) PROQTY=1
  S PROQTY=$$RJ^XLFSTR(PROQTY,8,0)
- S ^TMP($J,ECXFEKEY,-PROQTY,SUBDA,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)
+ S ^TMP($J,ECXFEKEY,-PROQTY,PROSSN)=PRONAME_U_PROSSN_U_PRODAY_U_ECXHCPCS_U_ECXFEKEY_U_PROQTY_U_"$"_$FNUMBER(PROCOST,",",2)
  S COUNT=COUNT+1
  I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUSUR.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUSUR.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUSUR.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 9/4/07 8:19am
- ;;3.0;DSS EXTRACTS;**49,71,84,93,105**;July 1, 2003;Build 70
+ECXUSUR ;ALB/TJL-Surgery Extract Unusual Volume Report ; 4/11/06 10:44AM
+ ;;3.0;DSS EXTRACTS;**49,71,84,93**;July 1, 2003
  ;
 EN ; entry point
@@ -89,10 +89,9 @@
  ..S COUNT=COUNT+1
  ..I $Y+3>IOSL D HEADER Q:QFLG
- ..W !,?1,$P(REC,U),?7,$P(REC,U,2),?18,$P(REC,U,3),?27,$P(REC,U,4)
- ..W ?34,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,7),4)
- ..W ?66,$$RJ^XLFSTR($P(REC,U,11),4),?77,$$RJ^XLFSTR($P(REC,U,9),4)
- ..W ?86,$$RJ^XLFSTR($P(REC,U,10),4),?93,$$RJ^XLFSTR($P(REC,U,6),4)
- ..W ?103,$$RJ^XLFSTR($P(REC,U,8),4),?113,$P(REC,U,14)
- ..W ?117,$P(REC,U,13)
+ ..W !,$P(REC,U),?6,$P(REC,U,2),?17,$P(REC,U,3),?26,$P(REC,U,4)
+ ..W ?33,$P(REC,U,5),?55,$$RJ^XLFSTR($P(REC,U,9),4)
+ ..W ?63,$$RJ^XLFSTR($P(REC,U,10),4),?74,$$RJ^XLFSTR($P(REC,U,11),4)
+ ..W ?83,$$RJ^XLFSTR($P(REC,U,6),4),?90,$$RJ^XLFSTR($P(REC,U,8),4)
+ ..W ?101,$$RJ^XLFSTR($P(REC,U,7),4),?114,$P(REC,U,13)
  Q:QFLG
  I COUNT=0 W !!,?8,$S(ECXFLAG=1:"No surgery volumes to report for this extract",1:"No unusual volumes to report for this extract")
@@ -113,8 +112,8 @@
  W !,"Start Date: ",ECSTART,?97,"Report Run Date/Time: "_ECRUN
  W !,"  End Date: ",ECEND I 'ECXFLAG W ?97,"     Threshold Value: ",ECTHLD
- W !!,?28,"Case",?38,"Encounter",?52,"Pt Holding",?63,"Anesthesia",?75,"Patient",?83,"Operation",?93,"PACU",?101,"OR Clean",?111,"Canc/",?121,"Principal"
- W !,?1,"Name",?10,"SSN",?20,"Day",?27,"Number",?40,"Number"
- W ?54,"Time",?66,"Time",?77,"Time",?86,"Time",?93,"Time",?103,"Time"
- W ?111,"Abort",?121,"Procedure"
+ W !!,?27,"Case",?37,"Encounter",?53,"Patient",?61,"Operation",?71,"Anesthesia",?83,"PACU",?89,"OR Clean",?99,"Pt Holding",?114,"Principal"
+ W !,"Name",?9,"SSN",?19,"Day",?26,"Number",?39,"Number"
+ W ?55,"Time",?63,"Time",?74,"Time",?83,"Time",?90,"Time",?101,"Time"
+ W ?114,"Procedure"
  W !,LN,!
  Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUSUR1.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUSUR1.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUSUR1.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 1/8/08 9:58am
- ;;3.0;DSS EXTRACTS;**49,71,105,111**;July 1, 2003;Build 4
+ECXUSUR1 ;ALB/TJL-Surgery Extract Unusual Volume Report ; 12/1/04 4:48pm
+ ;;3.0;DSS EXTRACTS;**49,71**;July 1, 2003
 EN ;
  N ECHEAD,COUNT,TIMEDIF,ECXPROC
@@ -62,9 +62,5 @@
  S ECODE0=TIME_U_ECODE0 K TIME
  ;
- I ECNL]"" S $P(ECODE0,U,2)=ECNT
- ;
- ;- Was surgery cancelled/aborted
- S ECCAN=$P($G(^SRF(ECD0,30)),U)
- I +ECCAN S ECCAN=$$CANC^ECXUTL4(ECNL,$P(DATA2,U,10))
+ I ECNL]"" S $P(ECODE0,U,5)=ECNT
  ;
  I ECXFLAG D FILE  Q
@@ -74,5 +70,4 @@
  . I $P(ECODE0,U,PIECE)>ECTHLD S FILE="YES"
  . I $P(ECODE0,U,PIECE)<0 S FILE="YES"
- ;
  I FILE="YES" D FILE Q:ECXERR
  Q
@@ -95,8 +90,8 @@
  S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXSTOP,ECSS) Q:ECXENC=""
  ;
- S VOL=$P(ECODE0,U)
- I $P(ECODE0,U,2)>VOL S VOL=$P(ECODE0,U,2)
- I $P(ECODE0,U,3)>VOL S VOL=$P(ECODE0,U,3)
- S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC_U_ECCAN
+ S VOL=$P(ECODE0,U,4)
+ I $P(ECODE0,U,5)>VOL S VOL=$P(ECODE0,U,5)
+ I $P(ECODE0,U,6)>VOL S VOL=$P(ECODE0,U,6)
+ S ^TMP($J,-VOL,-ECD0)=SURNAME_U_SURSSN_U_SURDT_U_ECD0_U_ECXENC_U_ECODE0_U_ECXPROC
  S COUNT=COUNT+1
  I COUNT#100=0 I $$S^ZTLOAD S (ZSTOP,ECXERR)=1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL2.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUTL2.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL2.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 6/12/07 6:38am
- ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105**;Dec 22, 1997;Build 70
+ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ; 11/2/06 9:03am
+ ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92**;Dec 22, 1997;Build 30
  ;
 ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1
@@ -13,4 +13,5 @@
  ;   ECXPIECE= running piece field (#11)
  ;   ECXVER  = dss version
+ ;
  N ECXIEN,ECXARR,DIC,DA,DR,DIQ
  S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0
@@ -49,4 +50,5 @@
  S ECXVER=7
  Q
+ ;
 PATDEM(DFN,DT1,PAR,FLG) ; determine patient information
  ;  DFN   =
@@ -76,5 +78,4 @@
  .S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC")
  .S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL")
- .S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT")
  I PAR["6" D
  .S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI)
@@ -97,4 +98,5 @@
  K ECXSBGRP
  Q
+ ;
 ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority
  ;and user enrollee status
@@ -109,4 +111,5 @@
  ;    ECXUESTA = User enrollee
  ;    return value 0 if no data found, 1 if data found
+ ;
  N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP
  S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)=""
@@ -139,4 +142,5 @@
  S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
  Q 1
+ ;
 PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider
  ; input
@@ -146,7 +150,7 @@
  ;             defaults to "2" if not specified otherwise
  ; output
- ; ECXPRIME  = pc team ien^prefix_pc provider ien^pc provider person
- ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider
- ;person class^assoc pc provider npi
+ ; ECXPRIME  = pc team ien^prefix_pc provider ien^pc provider person class^pc provider npi
+ ;             ^prefix_assoc pc provider ien^assoc pc provider person class^assoc pc provider npi
+ ;
  N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2
  S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2
@@ -156,7 +160,6 @@
  S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE)
  S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
- N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE)
- S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U)
  S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR
+ S ECPTNPI=""
  ;assoc pc provider call ok if routine scapmca from patch177 is present
  S ECASPR=""
@@ -164,10 +167,10 @@
  .S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE)
  S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE)
- N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE)
- S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U)
  S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR
+ S ECASNPI=""
  ;assemble
  S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI
  Q ECXPRIME
+ ;
 INP(ECXDFN,ECXDATE) ; check for inpatient status
  ; input
@@ -182,4 +185,5 @@
  ;           where patient status = I for inpatient
  ;                                = O for outpatient
+ ;
  N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO
  N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC
@@ -187,4 +191,5 @@
  D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
  S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
+ ;
  ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient)
  S DFN=ECXDFN,ECA="O"
@@ -194,4 +199,5 @@
  I ECMN D
  .S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS=""
+ .;
  .;- Get inpat/outpat indicator
  .S ECA=$$INOUTP^ECXUTL4(ECTS)
@@ -212,7 +218,9 @@
  S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC
  Q ECXINP
+ ;
 VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data
  ; input  ECXDFN = patient file ien
  ; output ECXPAYOR, ECXSAI (passed by reference)
+ ;
  N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA
  S (ECXPAYOR,ECXSAI)=""
@@ -226,4 +234,5 @@
  ;K ECXARY,ECXERR
  I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D
+ . W !,"This is a test"
  . I $D(ECXERR) Q
  . S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL3.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUTL3.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL3.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 9/28/07 1:38pm
- ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105**;Dec 22,1997;Build 70
+ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ; 11/2/06 9:07am
+ ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92**;Dec 22,1997;Build 30
  ;
 OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT
@@ -69,7 +69,5 @@
  I ECXDFN="" Q 0
  S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0
- I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0  ;test patient
- ;test patient extended checks; mtl extract excluded
- I $G(ECHEAD)'="MTL",'$$SSN^ECXUTL5(SSN) K ECXPAT Q 0
+ I $E(SSN,1,5)="00000"!(SSN="") K ECXPAT Q 0  ;test patient
  S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;"
  S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;"
@@ -149,7 +147,4 @@
  . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam)
  . S ECXPAT("AOL")=$P($G(VASV(2,5)),U)
- . ;get patient OEF/OIF status and date of return
- . D OEFDATA^ECXUTL4
- . ;
  . ;get patient current MST status
  . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL4.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUTL4.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL4.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/26/07 10:58am
- ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92,105**;Dec 22,1997;Build 70
+ECXUTL4 ;ALB/ESD - Utilities for DSS Extracts ; 11/2/06 9:08am
+ ;;3.0;DSS EXTRACTS;**39,41,46,49,78,92**;Dec 22,1997;Build 30
  ;
 OBSPAT(ECXIO,ECXTS,DSSID) ;
@@ -271,18 +271,2 @@
  F I=1:1:$L(TS) Q:$P(TS,"^",I)=ECXTS
  Q $P(SC,"^",I)_"000"
-OEFDATA ;
- ;get patient OEF/OIF status and date of return
- S (ECXOEF,ECXOEFDT)=""
- I $G(VASV(11))>0 S ECXOEF=ECXOEF_"OIF"
- I $G(VASV(12))>0 S ECXOEF=ECXOEF_"OEF"
- I $G(VASV(13))>0 S ECXOEF=ECXOEF_"UNK"
- I ECXOEF'="" D
- . S ECXOEFDT=""
- . I $G(VASV(11))>0 S ECXOEFDT=$P($G(VASV(11,$G(VASV(11)),3)),"^")
- . I $G(VASV(12))>0,$P($G(VASV(12,$G(VASV(12)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(12,$G(VASV(12)),3)),"^")
- . I $G(VASV(13))>0,$P($G(VASV(13,$G(VASV(13)),3)),"^")>ECXOEFDT S ECXOEFDT=$P($G(VASV(13,$G(VASV(13)),3)),"^")
- . I ECXOEFDT>0 S ECXOEFDT=17000000+ECXOEFDT
- ;
- S ECXPAT("ECXOEF")=ECXOEF
- S ECXPAT("ECXOEFDT")=ECXOEFDT
- Q
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL5.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUTL5.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL5.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 10/17/07 3:49pm
- ;;3.0;DSS EXTRACTS;**71,84,92,103,105**;Dec 22, 1997;Build 70
+ECXUTL5 ;ALB/JRC - Utilities for DSS Extracts ; 01/18/07 9:04am
+ ;;3.0;DSS EXTRACTS;**71,84,92,103**;Dec 22, 1997;Build 1
  ;
 REPEAT(CHAR,TIMES) ;REPEAT A STRING
@@ -207,18 +207,2 @@
  D DIQ^PSODI(DIC,DIC,DR,DA,DIQ)
  Q $S($G(ECXDIQ(52,DA,116))="YES":"Y",$G(ECXDIQ(52,DA,116))="NO":"N",1:"")
- ;
-SSN(SSN,FILE) ; extended validation of ssn
- ;       input:     ssn - social security number to validate
- ;                  file - optional "", 2 or 67, the only check is for
- ;                         reference lab file (#67) in which case ssn
- ;                         "000123456" is considered a valid ssn.
- ;        output:   0 - test patient or invalid ssn
- ;                  1 - valid ssn
- ;
- ;check input
- I $G(SSN)']"" Q 0
- S FILE=$G(FILE)
- I (FILE=67)&(SSN="000123456") Q 1
- I "89"[$E(SSN) Q 0
- I (SSN="123456789")!(SSN="111111111")!(SSN="222222222")!(SSN="333333333")!(SSN="444444444")!(SSN="555555555")!($E(SSN,1,3)="666")!($E(SSN,4,5)="00")!($E(SSN,1,3)="000") Q 0
- Q 1
Index: FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL6.m
===================================================================
--- FOIAVistA/trunk/r/DSS_EXTRACTS-ECX/ECXUTL6.m	(revision 631)
+++ FOIAVistA/tag/r/DSS_EXTRACTS-ECX/ECXUTL6.m	(revision 636)
@@ -1,4 +1,4 @@
-ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/28/07 11:34am
- ;;3.0;DSS EXTRACTS;**92,105**;Dec 22, 1997;Build 70
+ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ; 11/2/06 8:30am
+ ;;3.0;DSS EXTRACTS;**92**;Dec 22, 1997;Build 30
  ;
 NUTKEY(P,D) ;Generate n&fs feeder key
@@ -6,5 +6,5 @@
  ;      p  - diet type production diet, standing orders, supplemental
  ;           feedings, or tube feedings.
- ;      d  - diet ien from files 116.2, 118.3, 118, or 118.2
+ ;      d  - diet ien from files 116.2, 116.3, 118, or 118.2
  ;Check input
  I $G(P)=""!'$G(D) Q ""
@@ -13,5 +13,5 @@
  S (PRO,IENS,CODE,DIET)=0
  S PRO=$O(^ECX(728.45,"B",P,PRO))
- S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(118.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"")
+ S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(116.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"")
  S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET))
  S IENS=""_DIET_","_PRO_","_""
@@ -28,6 +28,6 @@
  ;            location
  ;Init variables
- N WARD,TRSVP,CRSVP,OPLOC,MASWARD
- S (CRSVP,TRSVP)=0,(WARD,DLT,DFL,MASWARD)=""
+ N WARD,TRSVP,OPLOC,MASWARD
+ S TRSVP=0,(WARD,ECXDLT,ECXDFL,MASWARD)=""
  S OPLOC=""
  ;Check input
@@ -38,7 +38,6 @@
  ;119.72 (production facility) field 2.
  I P="INP" D
- .S WARD=$P($G(^FHPT(FHDFN,"A",+ECXADM,0)),U,8)
+ .S WARD=$P($G(^FHPT(FHDFN,"A",ECXADM,0)),U,8)
  .S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I")
- .S CRSVP=$$GET1^DIQ(119.6,WARD,4,"I")
  .;Get divisions
  .D GETDIV
@@ -80,5 +79,5 @@
  I P["OP",D["GM" D
  .S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
- .S FPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I")
+ .S ECXFPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I")
  .;Get delivery division
  .D GETDIV
@@ -96,25 +95,16 @@
  ;   all other meals are null
  I P="INP",D="PD" D
- .S DLT=$P($G(NODE),U,8)
+ .S ECXDLT=$P($G(NODE),U,8)
  I P="OP",((D="RM")!(D="SM")) D
- .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1)
+ .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1)
  I P="OP",D="GM" D
- .S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1)
+ .S ECXDLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1)
  ;
  ;Delivery feeder location
- I DLT="C" D
- .S DFL=$E($$GET1^DIQ(119.6,WARD,4,"E"),1,10)
- .S IEN=$$GET1^DIQ(119.72,+CRSVP,2,"I")
- .S IEN=""_IEN_";FH(119.71,"
- .S FPF=$O(^ECX(728.46,"B",IEN,FPF))
- .S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
- I (DLT["T")!(DLT["D") D
- .I P="INP" D
- ..S MASWARD=$O(^FH(119.6,+WARD,"W","B",0))
- ..S DFL=$$GET1^DIQ(42,+MASWARD,44,"I")
- .I P="OP" D
- ..S DFL=$O(^FH(119.6,+OPLOC,"L","B",0))
- I (DLT=""),"SFTFSO"[D D
- .S DFL=$S(TRSVP:$$GET1^DIQ(119.6,WARD,3,"E"),1:$$GET1^DIQ(119.6,WARD,4,"E"))
+ I ECXDLT="C" S ECXDFL=$P(NODE,U,8) D
+ .S ECXDFL=$E($$GET1^DIQ(119.72,ECXDFL,2,"E"),1,10)
+ I (ECXDLT["T")!(ECXDLT["D") D
+ .S MASWARD=$O(^FH(119.6,$S(WARD:+WARD,+OPLOC:+OPLOC,1:""),"W","B",0))
+ .S ECXDFL=$$GET1^DIQ(42,+MASWARD,44,"I")
  Q 1
  ;
@@ -122,54 +112,17 @@
  ;Init variables
  N IEN,SIEN
- S (FDD,FPF,FPD)=""
+ S (ECXFDD,ECXFPF,ECXFPD)=""
  S IEN=$$GET1^DIQ(119.72,+TRSVP,2,"I")
  Q:'IEN
  ;Get delivery division
  S SIEN=""_+TRSVP_";FH(119.72,"
- S FDD=$O(^ECX(728.46,"B",SIEN,FDD))
- S FDD=""_$$GET1^DIQ(728.46,FDD,1,"I")_","_""
- S FDD=$$GET1^DIQ(4,FDD,99,"E")
+ S ECXFDD=$O(^ECX(728.46,"B",SIEN,ECXFDD))
+ S ECXFDD=""_$$GET1^DIQ(728.46,ECXFDD,1,"I")_","_""
+ S ECXFDD=$$GET1^DIQ(4,ECXFDD,99,"E")
  ;Get production division and food production facility
  S IEN=""_IEN_";FH(119.71,"
- S FPF=$O(^ECX(728.46,"B",IEN,FPF))
- S FPD=""_$$GET1^DIQ(728.46,FPF,1,"I")_","_""
- S FPD=$$GET1^DIQ(4,FPD,99,"E")
- S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
+ S ECXFPF=$O(^ECX(728.46,"B",IEN,ECXFPF))
+ S ECXFPD=""_$$GET1^DIQ(728.46,ECXFPF,1,"I")_","_""
+ S ECXFPD=$$GET1^DIQ(4,ECXFPD,99,"E")
+ S ECXFPF=$E($$GET1^DIQ(728.46,ECXFPF,.01,"E"),1,10)
  Q
- ;
-SUR(CRST,STCD,CLINIC) ;Surgery stop codes and clinic (outpatients only)
- ;Init variables
- S (CRST,STCD,CLINIC)=""
- ;Quit if not outpatient
- Q:$P(EC0,U,12)'="O" ""
- ;Get stop codes (outpatient only)
- I $P(EC0,U,12)="O" D
- .;Get credit stop code (outpatient only)
- .S CRST=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",2503,"I")_","_"",1,"E")
- .;Get stop code (outpatient only)
- .S STCD=""_$$GET1^DIQ(40.7,""_$$GET1^DIQ(44,$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")_","_""_","_"",8,"I")_","_"",1,"E")
- ;Clinic for non-or case use associated clinic else non-or location
- ;If non-or case
- I $P($G(ECNO),U)="Y" S CLINIC=$S($P(EC0,U,21):$P(EC0,U,21),1:$P(ECNO,U,2))
- ;Get stop codes non-or cases
- I $P($G(ECNO),U)="Y" D
- .;Get credit stop code for non-or case
- .S CRST=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,2503,"I"),1,"E")
- .;Get stop code for non-or case
- .S STCD=$$GET1^DIQ(40.7,$$GET1^DIQ(44,CLINIC,8,"I"),1,"E")
- ;Clinic, not a non-or case use surgical specialty associated clinic
- I $P($G(ECNO),U)'="Y" S CLINIC=$$GET1^DIQ(137.45,+$P(EC0,U,4),2,"I")
- Q 1
- ;
-SURPODX(PRODX,PODX1,PODX2,PODX3,PODX4,PODX5) ;Get postop diagnosis codes
- ;Init variables
- N CODE,I,PODX
- S (PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)="",CODE=0
- ;Check input
- Q:'$D(DATAOP) 0
- ;Get principal postop dx code
- S PRODX=$$GET1^DIQ(80,$P(DATAOP,U,3),.01)
- ;Get other postop dx codes
- S (CODE,I)=0 F  S CODE=$O(^SRO(136,ECD0,4,CODE)) Q:'CODE  Q:I>5  D
- .S I=I+1,PODX="PODX"_I,@PODX=$$GET1^DIQ(80,$P(^SRO(136,ECD0,4,CODE,0),U),.01)
- Q 1
Index: FOIAVistA/tag/r/ENGINEERING-EN/ENEQ4.m
===================================================================
--- FOIAVistA/trunk/r/ENGINEERING-EN/ENEQ4.m	(revision 631)
+++ FOIAVistA/tag/r/ENGINEERING-EN/ENEQ4.m	(revision 636)
@@ -1,4 +1,4 @@
-ENEQ4 ;WIRMFO/SAB-PURGE EQUIPMENT INV FILE ;12/28/07  13:54
- ;;7.0;ENGINEERING;**40,87**;Aug 17, 1993;Build 16
+ENEQ4 ;WIRMFO/SAB-PURGE EQUIPMENT INV FILE ;2.25.97
+ ;;7.0;ENGINEERING;**40**;Aug 17, 1993
  ;
 DEL ;Delete Equipment Record entry
@@ -36,5 +36,4 @@
  I $P(ENY(3),U,1)=1 S ENV(4)="USE STATUS is IN USE."
  I $P(ENY(3),U,11)="" S ENV(5)="DISPOSITION DATE is blank."
- I $D(^ENG(6916.3,"B",ENDA)) S ENV(6)="It is linked to an IT Assignment record."
  I $D(ENV) D  G DELSEQ
  . W $C(7),!,"This equipment entry can not be deleted because:"
Index: FOIAVistA/tag/r/ENGINEERING-EN/ENPLS2.m
===================================================================
--- FOIAVistA/trunk/r/ENGINEERING-EN/ENPLS2.m	(revision 631)
+++ FOIAVistA/tag/r/ENGINEERING-EN/ENPLS2.m	(revision 636)
@@ -1,4 +1,4 @@
-ENPLS2 ;WISC/SAB - Select Items from List ;12/4/07  13:24
- ;;7.0;ENGINEERING;**23,87**;Aug 17, 1993;Build 16
+ENPLS2 ;WISC/SAB - Select Items from List ;7/21/95
+ ;;7.0;ENGINEERING;**23**;Aug 17, 1993
 EN ; entry point
  ; input global
@@ -44,9 +44,7 @@
  K ENACL S ENI="" F  S ENI=$O(Y(ENI)) Q:ENI=""  S ENACL(ENI)=Y(ENI)
 EXIT ;
- W:'$G(ENGNOFF) @IOF
+ W @IOF
  K DX,DY
  Q
-EN2(ENGNOFF) ;Entry point to suppress Form Feed at end
- G EN
 SHD ; Screen Header
  W @IOF
Index: FOIAVistA/tag/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASEZPF.m
===================================================================
--- FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASEZPF.m	(revision 631)
+++ FOIAVistA/tag/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASEZPF.m	(revision 636)
@@ -1,4 +1,4 @@
-EASEZPF ;ALB/SCK/GAH - Print 1010EZ Enrollment form ; 10/19/2000
- ;;1.0;ENROLLMENT APPLICATION SYSTEM;**44,51,84**;Sep 5, 2006;Build 2
+EASEZPF ;ALB/SCK - Print 1010EZ Enrollment form ; 10/19/2000
+ ;;1.0;ENROLLMENT APPLICATION SYSTEM;**44,51**;Mar 15, 2001
  ;
  ; These routines print a version of the OMB approved VA10-10EZ form.
@@ -25,24 +25,17 @@
  ;
  S EASAPP=$G(EASAPP),EASDFN=$G(EASDFN)
- ; Can't be a slave
+ ;
  S %ZIS="Q",%ZIS("S")="I $P($G(^(1)),U)'[""SLAVE""&($P($G(^(0)),U)'[""SLAVE"")"
  D ^%ZIS
  ;
  G:POP EXIT
+ S ZUSR=DUZ,ZTRTN="EN^EASEZPF",ZTDESC="1010EZ PRINT"
  ;EAS*1*51 -- if version # 6 or greater, use new print format
- S ZTRTN="EN^EASEZPF"
  I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP)
  I '(EASVRSN<6) S ZTRTN="EN^EASEZP6F"
- ; Either queue for print or print manually by user choice (EAS*1.0*84)
- I $D(IO("Q")) D  G EXIT ;Queued print chosen
- . S ZUSR=DUZ,ZTDESC="1010EZ PRINT"
- . F X="ZUSR","EASAPP","EASDFN" S ZTSAVE(X)=""
- . D ^%ZTLOAD
- . D HOME^%ZIS
  ;
- ;Manual print chosen
- D @ZTRTN
- D ^%ZISC
- G EXIT
+ F X="ZUSR","EASAPP","EASDFN" S ZTSAVE(X)=""
+ D ^%ZTLOAD
+ D HOME^%ZIS
  ;
 EXIT Q +$G(ZTSK)
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX ; DRIVER FOR COMPILED XREFS FOR FILE #413 ; 10/15/04
+PRCNX ; DRIVER FOR COMPILED XREFS FOR FILE #413 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX1.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX1.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX1.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX1 ; COMPILED XREF FOR FILE #413 ; 10/15/04
+PRCNX1 ; COMPILED XREF FOR FILE #413 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX2.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX2.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX2.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX2 ; COMPILED XREF FOR FILE #413.015 ; 10/15/04
+PRCNX2 ; COMPILED XREF FOR FILE #413.015 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX3.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX3.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX3.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX3 ; COMPILED XREF FOR FILE #413.028 ; 10/15/04
+PRCNX3 ; COMPILED XREF FOR FILE #413.028 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX4.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX4.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX4.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX4 ; COMPILED XREF FOR FILE #413.046 ; 10/15/04
+PRCNX4 ; COMPILED XREF FOR FILE #413.046 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX5.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX5.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX5.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX5 ; COMPILED XREF FOR FILE #413 ; 10/15/04
+PRCNX5 ; COMPILED XREF FOR FILE #413 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX6.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX6.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX6.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX6 ; COMPILED XREF FOR FILE #413.015 ; 10/15/04
+PRCNX6 ; COMPILED XREF FOR FILE #413.015 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX7.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX7.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX7.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX7 ; COMPILED XREF FOR FILE #413.028 ; 10/15/04
+PRCNX7 ; COMPILED XREF FOR FILE #413.028 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX8.m
===================================================================
--- FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX8.m	(revision 631)
+++ FOIAVistA/tag/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNX8.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCNX8 ; COMPILED XREF FOR FILE #413.046 ; 10/15/04
+PRCNX8 ; COMPILED XREF FOR FILE #413.046 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXP.m
===================================================================
--- FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXP.m	(revision 631)
+++ FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXP.m	(revision 636)
@@ -1,3 +1,3 @@
-ECMXP ; GENERATED FROM 'EC CREATE PATIENT ENTRY' INPUT TEMPLATE(#1503), FILE 721;06/14/06
+ECMXP ; GENERATED FROM 'EC CREATE PATIENT ENTRY' INPUT TEMPLATE(#1503), FILE 721;10/08/06
  D DE G BEGIN
 DE S DIE="^ECH(",DIC=DIE,DP=721,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ECH(DA,""))=""
Index: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXP1.m
===================================================================
--- FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXP1.m	(revision 631)
+++ FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXP1.m	(revision 636)
@@ -1,3 +1,3 @@
-ECMXP1 ; ;06/14/06
+ECMXP1 ; ;10/08/06
  D DE G BEGIN
 DE S DIE="^ECH(",DIC=DIE,DP=721,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ECH(DA,""))=""
Index: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXPC.m
===================================================================
--- FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXPC.m	(revision 631)
+++ FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECMXPC.m	(revision 636)
@@ -1,3 +1,3 @@
-ECMXPC ; GENERATED FROM 'EC FILE PCE NODE' INPUT TEMPLATE(#1504), FILE 721;06/14/06
+ECMXPC ; GENERATED FROM 'EC FILE PCE NODE' INPUT TEMPLATE(#1504), FILE 721;10/08/06
  D DE G BEGIN
 DE S DIE="^ECH(",DIC=DIE,DP=721,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^ECH(DA,""))=""
Index: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m
===================================================================
--- FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m	(revision 631)
+++ FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECRRPT.m	(revision 636)
@@ -1,4 +1,4 @@
 ECRRPT ;ALB/JAM;Event Capture Report RPC Broker ;Jan 2, 2001
- ;;2.0; EVENT CAPTURE ;**25,32,41,56,61,82,94**;8 May 96;Build 4
+ ;;2.0; EVENT CAPTURE ;**25,32,41,56,61,82**;8 May 96
  ;
 REQCHK(ECV) ;Required data check
@@ -74,5 +74,5 @@
  . . S ECKEY=$S($D(^XUSEC("ECALLU",ECDUZ)):1,1:0),DUZ=ECDUZ D ALLU^ECRUTL
  . S (ECI,ECNT)=0 F ECI=0:1 S ECX="ECD"_ECI Q:'$D(@ECX)  D
- . . K DIC S DIC=724,DIC(0)="QNZX",X=@ECX D ^DIC I Y<0 Q
+ . . K DIC S DIC=724,DIC(0)="QNMZX",X=@ECX D ^DIC I Y<0 Q
  . . S ECNT=ECNT+1,ECDSSU(ECNT)=Y
  D DATECHK(.ECSD,.ECED)
Index: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECUMRPC1.m
===================================================================
--- FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECUMRPC1.m	(revision 631)
+++ FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECUMRPC1.m	(revision 636)
@@ -1,4 +1,4 @@
 ECUMRPC1 ;ALB/JAM-Event Capture Management Broker Utilities ;28 Nov 00
- ;;2.0; EVENT CAPTURE ;**25,30,33,72,94**;8 May 96;Build 4
+ ;;2.0; EVENT CAPTURE ;**25,30,33,72**;8 May 96
  ;
 DSSUNT(RESULTS,ECARY) ;
@@ -69,6 +69,5 @@
  . S CRDT=$$FMTE^XLFDT($P(NODE,U,2),"2F")
  . S INDT=$$FMTE^XLFDT($P(NODE,U,3),"2F")
- . ;S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT
- . S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_$P(CRDT,"@",1)_U_$P(INDT,"@",1)
+ . S CNT=CNT+1,^TMP($J,"ECCAT",CNT)=CAT_U_$P(NODE,U)_U_CRDT_U_INDT
  S RESULTS=$NA(^TMP($J,"ECCAT"))
  Q
Index: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m
===================================================================
--- FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m	(revision 631)
+++ FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECUURPC.m	(revision 636)
@@ -1,4 +1,4 @@
 ECUURPC ;ALB/JAM;Event Capture Data Entry Broker Utilities ;Aug 28, 2000
- ;;2.0; EVENT CAPTURE ;**25,42,49,94**;8 May 96;Build 4
+ ;;2.0; EVENT CAPTURE ;**25,42,49**;8 May 96
  ;
 ECHELP(RESULTS,ECARY) ;
@@ -33,5 +33,4 @@
  S FIL=$P(ECARY,U),TXT=$P(ECARY,U,2) I TXT=""!(FIL="") Q
  S DIC=FIL,DIC(0)="MN",X=TXT
- I FIL=81.3 S DIC("S")="I $P(^DIC(81.3,Y,0),U,5)'=1" ;PATCH 94
  D ^DIC I Y=-1 Q
  S RESULTS=+Y
Index: FOIAVistA/tag/r/E_CLAIMS_MGMT_ENGINE-BPS/BPS01P5A.m
===================================================================
--- FOIAVistA/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPS01P5A.m	(revision 631)
+++ FOIAVistA/tag/r/E_CLAIMS_MGMT_ENGINE-BPS/BPS01P5A.m	(revision 636)
@@ -1,4 +1,21 @@
 BPS01P5A ;BHAM ISC/BEE - Post-Install for BPS*1*5 (cont) ;13-DEC-06
- ;;1.0;E CLAIMS MGMT ENGINE;**5**;JUN 2004;Build 45
+ ;;1.0;E CLAIMS MGMT ENGINE;**5**;JUN 2004;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -136,5 +153,5 @@
  ;
  ;Turn global protection off (SACC Exemption has been granted to use $ZU)
- S X=$ZU(68,28,0)
+ I $P(^%ZOSF("OS"),"^",2)=3 S X=$ZU(68,28,0)
  ;
  ;Remove BPS COMBINED INSURANCE (#9002313.1), which uses an unsubscripted global 
@@ -147,5 +164,5 @@
  ;
  ;Turn global protection back on
- S X=$ZU(68,28,1)
+  I $P(^%ZOSF("OS"),"^",2)=3 S X=$ZU(68,28,1)
  ;
  ;BPS DATA INPUT (#9002313.51)
Index: FOIAVistA/tag/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSSCRRV.m
===================================================================
--- FOIAVistA/trunk/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSSCRRV.m	(revision 631)
+++ FOIAVistA/tag/r/E_CLAIMS_MGMT_ENGINE-BPS/BPSSCRRV.m	(revision 636)
@@ -1,5 +1,22 @@
 BPSSCRRV ;BHAM ISC/SS - ECME SCREEN REVERSE CLAIM ;05-APR-05
- ;;1.0;E CLAIMS MGMT ENGINE;**1,5**;JUN 2004;Build 45
+ ;;1.0;E CLAIMS MGMT ENGINE;**1,5**;JUN 2004;Build 4;WorldVistA 30-Jan-08
  ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  Q
  ;IA 4702
@@ -39,5 +56,6 @@
  . W !,"You've chosen to REVERSE the following prescription for "_$E($$PATNAME^BPSSCRU2(BPDFN),1,13)
  . W !,$G(@VALMAR@(+$G(BP59ARR(BP59)),0))
- . F  S BPRVREAS=$$COMMENT^BPSSCRCL("Enter REQUIRED REVERSAL REASON",60) Q:BPRVREAS="^"  Q:($L(BPRVREAS)>0)&&(BPRVREAS'="^")&&('(BPRVREAS?1" "." "))  D
+ . ;F  S BPRVREAS=$$COMMENT^BPSSCRCL("Enter REQUIRED REVERSAL REASON",60) Q:BPRVREAS="^"  Q:($L(BPRVREAS)>0)&&(BPRVREAS'="^")&&('(BPRVREAS?1" "." "))  D
+ . F  S BPRVREAS=$$COMMENT^BPSSCRCL("Enter REQUIRED REVERSAL REASON",60) Q:BPRVREAS="^"  Q:($L(BPRVREAS)>0)&(BPRVREAS'="^")&('(BPRVREAS?1" "." "))  D
  . . W !,"Please provide the reason or enter ^ to abandon the reversal."
  . I BPRVREAS["^" W !,"The claim: ",!,$G(@VALMAR@(+$G(BP59ARR(BP59)),0)),!,"was NOT reversed!" S BPQ=$$PAUSE() Q
Index: FOIAVistA/tag/r/FEE_BASIS-FB/FBAAFSR.m
===================================================================
--- FOIAVistA/trunk/r/FEE_BASIS-FB/FBAAFSR.m	(revision 631)
+++ FOIAVistA/tag/r/FEE_BASIS-FB/FBAAFSR.m	(revision 636)
@@ -1,4 +1,4 @@
 FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999
- ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102,105**;JAN 30, 1995;Build 1
+ ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102**;JAN 30, 1995;Build 24
  ;
  Q
@@ -172,16 +172,12 @@
  N GPCI,RVU,FBI,TMP,TMPRVU
  S FBAMT=0
- ;Old formula for RBRVS pre-2007 payment amounts
+ ;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994)
  I DOS<3070101 D
+ .;Old formula for RBRVS pre-2007 payment amounts
  .S RVU(1)=$P(FBCPTY0,U,3)
- I (DOS=3070101!(DOS>3070101)&(DOS<3080101)) D
+ I DOS>3061231 D
  .;New formula for RBRVS 2007 payment amounts
  .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994)
  .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2)
- .S RVU(1)=TMPRVU
- I DOS=3080101!(DOS>3080101) D
- .;New formula for the RBRVS 2008 payment amounts
- .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994)
- .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8806)),".",2)
  .S RVU(1)=TMPRVU
  S RVU(2)=$P(FBCPTY0,U,4+FAC)
Index: FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV.m
===================================================================
--- FOIAVistA/trunk/r/FEE_BASIS-FB/FBCTV.m	(revision 631)
+++ FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV.m	(revision 636)
@@ -1,3 +1,3 @@
-FBCTV ; GENERATED FROM 'FB VENDOR UPDATE' INPUT TEMPLATE(#1055), FILE 161.2;06/29/07
+FBCTV ; GENERATED FROM 'FB VENDOR UPDATE' INPUT TEMPLATE(#1055), FILE 161.2;12/27/07
  D DE G BEGIN
 DE S DIE="^FBAAV(",DIC=DIE,DP=161.2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^FBAAV(DA,""))=""
Index: FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV1.m
===================================================================
--- FOIAVistA/trunk/r/FEE_BASIS-FB/FBCTV1.m	(revision 631)
+++ FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV1.m	(revision 636)
@@ -1,3 +1,3 @@
-FBCTV1 ; ;06/29/07
+FBCTV1 ; ;12/27/07
  S X=DE(15),DIC=DIE
  K ^FBAAV("NPI",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV2.m
===================================================================
--- FOIAVistA/trunk/r/FEE_BASIS-FB/FBCTV2.m	(revision 631)
+++ FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV2.m	(revision 636)
@@ -1,3 +1,3 @@
-FBCTV2 ; ;06/29/07
+FBCTV2 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S ^FBAAV("NPI",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV3.m
===================================================================
--- FOIAVistA/trunk/r/FEE_BASIS-FB/FBCTV3.m	(revision 631)
+++ FOIAVistA/tag/r/FEE_BASIS-FB/FBCTV3.m	(revision 636)
@@ -1,3 +1,3 @@
-FBCTV3 ; ;06/29/07
+FBCTV3 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^FBAAV(",DIC=DIE,DP=161.2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^FBAAV(DA,""))=""
Index: FOIAVistA/tag/r/GEN_MED_REC_VITALS-GMRV/GMRVED2.m
===================================================================
--- FOIAVistA/trunk/r/GEN_MED_REC_VITALS-GMRV/GMRVED2.m	(revision 631)
+++ FOIAVistA/tag/r/GEN_MED_REC_VITALS-GMRV/GMRVED2.m	(revision 636)
@@ -1,4 +1,4 @@
-GMRVED2 ;HIOFO/RM,YH,FT-VITAL SIGNS EDIT SHORT FORM ;11/15/04  10:30
- ;;5.0;GEN. MED. REC. - VITALS;**2**;Oct 31, 2002
+GMRVED2 ;HIOFO/RM,YH,FT-VITAL SIGNS EDIT SHORT FORM ;7/20/07  13:43
+ ;;5.0;GEN. MED. REC. - VITALS;**2**;Oct 31, 2002;Build 11
  ;
  ; This routine uses the following IAs:
@@ -75,4 +75,6 @@
  I GMREDB="P1" S GMRVIEN(GMRVITY)=DA_"^"_GMRDAT(GMRVITY)_"^"_$G(GMRSITE(GMRVITY))
  S:GMRENTY>4 GLAST=GMRVIDT,GLAST(1)=$G(GLAST(1))+1
+ ; for VOE Pediatric Growth Charts
+ I "8920"[(+GMRVIT(1)) D EN^GMRVPGC(DFN) ; 8=Height 9=Weight 20=Circumference
  Q
 XREF(DA) ; Set cross-references for FILE 120.5 entry
Index: FOIAVistA/tag/r/HEALTH_DATA_AND_INFORMATICS-HDI/HDISVCMR.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_DATA_AND_INFORMATICS-HDI/HDISVCMR.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_DATA_AND_INFORMATICS-HDI/HDISVCMR.m	(revision 636)
@@ -1,4 +1,13 @@
-HDISVCMR ;CT/GRR Data Standardization ; 06 Oct 2005  2:12 PM
+HDISVCMR ;CT/GRR Data Standardization ; 20 APR 2006  12:17
  ;;1.0;HEALTH DATA & INFORMATICS;**1,2**;Feb 22, 2005
+ ;
+ ; 2005 05 16 (VA/JRP): fix broken IF/ELSE statement in EN.
+ ;
+ ; 2005 10 06 (VA/JRP): remove last parameter from call to
+ ; $$SNDXML^HDISVM02 at CREATE+12.
+ ;
+ ; 2006 04 11 (WV/TOAD): fix undefined error at CR8OUT when it is called
+ ; from CREATE+4, as was the case when GMRA*4*23 was installed on the
+ ; VOE server.
  ;
 EN(HDISDOM,HDISFILE) ;
@@ -41,4 +50,4 @@
  I 'HDISOUT S HDISMESS=$P(HDISOUT,"^",2) D ERR^HDISVF09(HDISNM,HDISDT,HDISMESS) G CR8OUT
  ;
-CR8OUT K @HDISARRY
+CR8OUT I $G(DISARRAY)'="" K @HDISARRY ; WV/TOAD: added IF to avoid UNDEF
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/04/2007  14:34
- ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132,122**;Oct 13, 1995;Build 14
+HLCS ;ALB/RJS,MTC,JRP - COMMUNICATIONS SERVER - ;10/31/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**2,9,14,19,43,57,109,132**;Oct 13, 1995;Build 6
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -48,14 +48,5 @@
  .N I,EXCLUDE
  .S (EXCLUDE,I)=0
- . ;
- . ; patch HL*1.6*122
- . ; F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q
- . F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  D  Q:EXCLUDE
- .. N TEMP
- .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)
- .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))
- .. I TEMP=HLEIDS S EXCLUDE=1
- . ; patch HL*1.6*122
- . ;
+ .F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  I $G(HLP("EXCLUDE SUBSCRIBER",I))=HLEIDS S EXCLUDE=1 Q
  .Q:EXCLUDE
  .;** 132 end **
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCS2.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCS2 ;SF/JC - More Communication Server utilities ; 10/04/2007  14:31
- ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCS2 ;SF/JC - More Communication Server utilities ; 12/31/2003  17:50
+ ;;1.6;HEALTH LEVEL SEVEN;**14,40,43,49,57,58,82,84,109**;Oct 13, 1995
 FWD ; Add supplemental clients from HLL("LINKS") to HLSUP array
  ;This enhancement also supports distribution of a message to
@@ -10,22 +9,8 @@
  . S PTR=$P(HLL("LINKS",CNT),"^"),LNK=$P(HLL("LINKS",CNT),"^",2)
  . Q:PTR=""  I +PTR<1 S PTR=$O(^ORD(101,"B",PTR,0)) Q:PTR<1
- . ;
- . ; patch HL*1.6*122: excluding subscribers defined in
- . ; HLP("EXCLUDE SUBSCRIBER",I) = ien of subscriber
- . N I,EXCLUDE
- . S (EXCLUDE,I)=0
- . F  S I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  D  Q:EXCLUDE
- .. N TEMP
- .. S TEMP=HLP("EXCLUDE SUBSCRIBER",I)
- .. I 'TEMP,TEMP]"" S TEMP=$O(^ORD(101,"B",TEMP,0))
- .. I TEMP=PTR S EXCLUDE=1
- . Q:EXCLUDE
- . ; 
  . Q:LNK=""  I +LNK<1 S LNK=$O(^HLCS(870,"B",LNK,0)) Q:LNK<1
  . Q:'$D(^HLCS(870,LNK))
  . S CLIAP=$$PTR^HLUTIL2(PTR)
- . ; patch HL*1.6*122: add the 3rd component as receiving facility
- . ; S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
- . S HLSUP("S",PTR,+LNK)=CLIAP_U_$S(CLIAP<1:HLL("LINKS",CNT),1:$P(HLL("LINKS",CNT),"^",3))
+ . S HLSUP("S",PTR,+LNK)=CLIAP_$S(CLIAP<1:U_HLL("LINKS",CNT),1:"")
  Q
 ADD ;Deliver message to supplemental client list.
@@ -39,13 +24,5 @@
  ..S ZLCLIENT=+HLSUP("S",ZHLEIDS,ZLOGLINK)
  ..I ZLCLIENT<1 S:$G(HLERROR)="" HLERROR="15^Invalid Subscriber Protocol in HLL('LINKS'): "_$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,2,9) Q
- .. ; patch HL*1.6*122 start
- .. ; S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
- .. S HLOGLINK=ZLOGLINK
- .. ; 3rd component for receiving facility
- .. S ZMTIENS("REC-FACILITY")=$P(HLSUP("S",ZHLEIDS,ZLOGLINK),U,3)
- .. D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK)
- .. D STATUS^HLTF0(+ZMTIENS,1)
- .. ; patch HL*1.6*122 end
- .. ;
+ ..S HLOGLINK=ZLOGLINK D SEND^HLMA2(ZHLEIDS,HLMTIEN,ZLCLIENT,"D",.ZMTIENS,ZLOGLINK),STATUS^HLTF0(+ZMTIENS,1)
  K HLL("LINKS"),HLSUP
  Q
@@ -95,22 +72,17 @@
  . I 'ALL&('$P(HLDP0,U,6)) Q
  . S HLPARM4=$G(^HLCS(870,HLDP,400))
- . ; patch HL*1.6*122
- . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- . ; or Cache/VMS
+ . ;TCP Multi listener for non-Cache uses UCX
  . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
- . ;
  . ;4=status,10=Time Stopped,9=Time Started,11=Task Number,3=Device Type,14=shutdown?
- . S X="HLJ(870,"""_HLDP_","")",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
- . I "Shutdown,SHUTDOWN"'[$P(HLDP0,U,5) S @X@(4)="Halting"
+ . S X="HLJ(870,"""_HLDP_","")",@X@(4)="Halting",@X@(10)=$$NOW^XLFDT,(@X@(11),@X@(9))="@",@X@(14)=1
  . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLDP0,U,12) S @X@(4)="Shutdown"
  . D FILE^HLDIE("","HLJ","","LLP","HLCS2") ;HL*1.6*109
+ . ;Cache system, need to open TCP port to release job
  . I ^%ZOSF("OS")["OpenM",($P(HLPARM4,U,3)="M"!($P(HLPARM4,U,3)="S")) D
- .. ; pass task number to stop listener
+ .. ;pass task number to stop listener
  .. S:$P(HLDP0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLDP0,U,12))
- ; patch HL*1.6*122 start
- ; .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
- ; .. I POP D HOME^%ZIS Q
- ; .. D CLOSE^%ZISTCP
- ; patch HL*1.6*122 end
+ .. D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+ .. I POP D HOME^%ZIS Q
+ .. D CLOSE^%ZISTCP
  Q
 STRT ;Start Links
@@ -126,9 +98,6 @@
  . Q:'HLTYPTR!(HLBGR="")
  . I HLENV'="" K HLQUIT X HLENV Q:$D(HLQUIT)
- . ; patch HL*1.6*122
- . ; TCP Multi listener: quit if TCP service as GT.M, DSM,
- . ; or Cache/VMS
+ . ;TCP Multi listener for non-Cache uses UCX
  . I $P(HLPARM4,U,3)="M" Q:^%ZOSF("OS")'["OpenM"  Q:$$OS^%ZOSV["VMS"
- . ;
  . I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  Q
  .. ;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSGTM.m	(revision 636)
@@ -1,4 +1,4 @@
 HLCSGTM ;OIFO-O/RWF - (TCP/IP) GT.M Linux ;08/13/2007
- ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 14
+ ;;1.6;HEALTH LEVEL SEVEN;**122**;Oct 13, 1995;Build 4;WorldVistA 30-Jan-08
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -7,4 +7,21 @@
  ;    number.
  ; 2. find the ien of #870(logical link file) for the multi-listener
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;04/17/2007
- ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133,122**;Oct 13, 1995;Build 14
+HLCSHDR1 ;SFIRMFO/RSD - Make HL7 header for TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,57,59,72,80,93,120,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
 HEADER(IEN,CLIENT,HLERROR) ; Create an HL7 MSH segment
@@ -147,11 +147,4 @@
  S:'ACKTO MSGTYPE=$P(PROT,U,2),EVNTYPE=$P(PROT,U,3),MSGEVN=$P(PROT,U,4)
  S ACCACK=$P(PROT,U,7),APPACK=$P(PROT,U,8)
- ;
- ; patch HL*1.6*122
- ; setting the MSH-15 and MSH-16 from subscriber protocol
- I HLPROTS,$P($G(^ORD(101,HLPROTS,773)),"^",5) D
- . S ACCACK=$P(PROTS,U,7)
- . S APPACK=$P(PROTS,U,8)
- ;
 PID ;Processing ID
  ;I PID not 'debug' get from site params
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSHDR4.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;10/09/2007 15:05
- ;;1.6;HEALTH LEVEL SEVEN;**93,108,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified
+HLCSHDR4 ;SFIRMFO/LJA - Reset MSH Segment Fields ;3/24/2004 14:27
+ ;;1.6;HEALTH LEVEL SEVEN;**93,108**;Oct 13, 1995
  ;
 DEBUG(STORE) ; If HLP set up for debugging, capture VIEW...
@@ -112,7 +111,4 @@
  ; Change was made, but not by M code.  Must be by array...
  S $P(HLMSH91,U,PCE)=PRE,$P(HLMSH91,U,PCE+1)="A"
- ;
- ; patch HL*1.6*122: for "^" as component separater
- S $P(HLMSH91,U,PCE+2,999)=""
  ;
  ; Upgrade ^HLMA(#,0)...
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSIN.m	(revision 636)
@@ -1,23 +1,13 @@
-HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;10/17/2007  14:58
- ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSIN ;ALB/JRP - INCOMING FILER;01-MAY-95 ;11/15/2000  09:37
+ ;;1.6;HEALTH LEVEL SEVEN;**2,30,14,19,62,109,115**;Oct 13, 1995
 STARTIN ;Main entry point for incoming background filer
  ;Create/find entry denoting this filer in the INCOMING FILER TASK
  ; NUMBER multiple (field #20) of the HL COMMUNICATION SERVER PARAMETER
  ; file (#869.3)
+ ;N HLOGLINK,HLNODE,HLPARENT,HLST1,TMP ; These vbls aren't used!
  N HLFLG,HLEXIT,HLPTRFLR
- ;
- ; patch HL*1.6*122
- ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
- N HLDUZ
- S HLDUZ=+$G(DUZ)
- ;
  S HLPTRFLR=+$$CRTFLR^HLCSUTL1(ZTSK,"IN")
  ;Loop through Logical Links and check for incoming messages
  S HLEXIT=0
- ; patch HL*1.6*122 TEST v2: DUZ code removed
- ; patch HL*1.6*122, set DUZ for application proxy user
- ;; D PROXY^HLCSTCP4
- S HLPTRFLR("$J")=$J
  F  D  Q:HLEXIT
  . S HLFLG=0
@@ -28,7 +18,5 @@
  . . S HLPTRFLR("LASTDEL")=$H    ; maintain queue sizes
  . . D DELQUE(.HLPTRFLR,.HLEXIT) ; no more than once an hour.
- . ; patch HL*1.6*122
- . ; H 5
- . H 1
+ . H 5
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
  S ZTSTOP=1 ;Asked to stop
@@ -40,10 +28,7 @@
  S HLXX=0
  F  S HLXX=$O(^HLMA("AC","I",HLXX)) Q:'HLXX  D  Q:HLEXIT
- . ; HL*1.6*122, check the in-queue stop flag
- . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- . ; patch HL*1.6*109: Does another filer have this?
- . ; L +^HLMA("AC","I",HLXX):0 Q:'$T
- . L +^HLMA("AC","I",HLXX):2 Q:'$T  ; patch HL*1.6*122
+ . ; HL*1.6*109
+ . L +^HLMA("AC","I",HLXX):0 Q:'$T  ;*109*Does another filer have this?
  . S HLD0=0,HLFLG=1
  . ; HL*1.6*109 changes in for loop below, and post-quit code placed
@@ -53,20 +38,11 @@
  . I ($$HDIFF^XLFDT($H,$G(^XTMP("HL7-AC","I",HLXX)),2)<2) L -^HLMA("AC","I",HLXX) Q
  . F  S HLD0=$O(^HLMA("AC","I",HLXX,HLD0)) Q:'HLD0!(HLEXIT)  D
- .. ; patch HL*1.6*122 start
- .. ; patch HL*1.6*122 TEST v2: DUZ code removed
- .. ; DUZ comparison/reset for application proxy user
- .. ;; D HLDUZ^HLCSTCP4
- .. D HLDUZ2^HLCSTCP4
- .. ; protect HLDUZ
- .. N HLDUZ
- .. S HLPCT=HLPCT+1
- .. I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- .. ; L +^HLMA(HLD0):0 Q:'$T
- .. F  L +^HLMA(HLD0):30 Q:$T  H 1
- .. I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q  ;-> Quit if not a valid AC xref
- .. D DEFACK^HLTP3(HLXX,HLD0)
- .. D DEQUE^HLCSREP(HLXX,"I",HLD0)
- .. L -^HLMA(HLD0)
- . ; patch HL*1.6*122 end
+ . . S HLPCT=HLPCT+1
+ . . I '(HLPCT#100) D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
+ . . L +^HLMA(HLD0):0 Q:'$T
+ . . I '$$CHECKAC("I",HLXX,HLD0) L -^HLMA(HLD0) Q  ;-> Quit if not a valid AC xref
+ . . D DEFACK^HLTP3(HLXX,HLD0)
+ . . D DEQUE^HLCSREP(HLXX,"I",HLD0)
+ . . L -^HLMA(HLD0)
  . ;**109 -add dt/tm stamp to time queue last processed
  . S ^XTMP("HL7-AC","I",HLXX)=$H
@@ -89,37 +65,16 @@
  S HLXX=0
  F  S HLXX=$O(^HLCS(870,"AISTAT","P",HLXX)) Q:'HLXX  D  Q:HLEXIT
- . ; HL*1.6*122, check the in-queue stop flag
- . Q:$P($G(^HLCS(870,HLXX,0)),"^",9)
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- . ; HL*1.6*109: Does another filer have this?
- . ; L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T
- . L +^HLCS(870,HLXX,"INFILER"):2 Q:'$T  ; patch HL*1.6*122
+ .; HL*1.6*109
+ . L +^HLCS(870,HLXX,"INFILER"):0 Q:'$T  ;Does another filer have this?
  . F  D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT  S HLD0=$$DEQUEUE^HLCSQUE(HLXX,"IN") Q:+HLD0<0  D
- .. ;
- .. ; patch HL*1.6*122 start
- .. ; clean variables except Kernel related variables
- .. D
- ... ; protect variables defined in STARTIN^HLCSIN
- ... N HLFLG,HLEXIT,HLPTRFLR
- ... N HLDUZ
- ... ; protect variables defined in ACKNOW^HLCSIN
- ... N HLXX,HLD0,HLD1
- ... D KILL^XUSCLEAN
- .. ;
- .. ; patch HL*1.6*122 TEST v2: DUZ code removed
- .. ; DUZ comparison/reset for application proxy user
- .. ;; D HLDUZ^HLCSTCP4
- .. D HLDUZ2^HLCSTCP4
- .. ; protect HLDUZ
- .. N HLDUZ
- .. ;Make sure message is ready to be received
- .. S HLFLG=1
- .. S HLD1=$P(HLD0,"^",2)
- .. S HLD0=+HLD0 ; At this point, HLD0=HLXX
- .. I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D  Q
- ... D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
- .. D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message
- .. D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
- . ; patch HL*1.6*122 end
+ . . ;Make sure message is ready to be received
+ . . S HLFLG=1
+ . . S HLD1=$P(HLD0,"^",2)
+ . . S HLD0=+HLD0 ; At this point, HLD0=HLXX
+ . . I $P($G(^HLCS(870,HLD0,1,HLD1,0)),"^",3)'="A" D  Q
+ . . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
+ . . D RECEIVE^HLMA0(HLD0,HLD1) ;Process received message
+ . . D MONITOR^HLCSDR2("D",2,HLD0,HLD1,"IN") ;Set status to DONE
  . I HLD0<0,$D(^HLCS(870,"AISTAT","P",HLXX)) D
  . . S HLD1=0 ; Make sure there aren't any loose xrefs hanging around.
@@ -134,9 +89,7 @@
  F  S HLXX=$O(^HLCS(870,HLXX)) Q:'HLXX  D  Q:HLEXIT
  . D CHKUPD(.HLPTRFLR,.HLEXIT) Q:HLEXIT
- . ; patch HL*1.6*122, comment out, no need to lock
- . ; L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T
+ . L +^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"):0 Q:'$T
  . S HLFRONT=$G(^HLCS(870,HLXX,"IN QUEUE FRONT POINTER"))
- . ; patch HL*1.6*122, comment out
- . ; L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
+ . L -^HLCS(870,HLXX,"IN QUEUE FRONT POINTER")
  . D DELETE^HLCSQUE1(HLXX,HLDIR,HLFRONT)
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSLNCH.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;07/26/2007  17:10
- ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSLNCH ;ALB/MTC/JC - START AND STOP THE LLP ;12/31/2003  17:37
+ ;;1.6;HEALTH LEVEL SEVEN;**6,19,43,49,57,75,84,109**;Oct 13, 1995
  ;
  ;This program is callable from a menu
@@ -24,11 +23,9 @@
  W !,"appropriate device.  Please select the node with which you want"
  W !,"to communicate",!
- ; patch HL*1.6*122
- S POP=0
  S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC G:Y<0 STARTQ
  S HLDP=+Y,HLDAPP=Y(0,0),HLTYPTR=+$P(Y(0),U,3),HLPARM0=Y(0)
  ;-- check if parameter have been setup
  ;-- check for LLP type
- I 'HLTYPTR W !!,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
+ I 'HLTYPTR W !,$C(7),"A Lower Layer Protocol must be selected before start-up can occur." G STARTQ
  ;-- get TCP information
  S HLPARM4=$G(^HLCS(870,HLDP,400))
@@ -38,40 +35,23 @@
  S HLENV=$G(^HLCS(869.1,HLTYPTR,200))
  ;
- I HLBGR="" W !!,$C(7),"No routine has been specified for this LLP." G STARTQ
+ I HLBGR="" W !,$C(7),"No routine has been specified for this LLP." G STARTQ
  ;
  ;-- execute environment check routine if HLQUIT is defined then terminate
  I HLENV'="" X HLENV G:$D(HLQUIT) STARTQ
- ; patch HL*1.6*122 start
- ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled
- ; by the external service
+ ;Multi-Servers, only enable the link if not OpenM
  I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  G STARTQ
  . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to start this LLP."
  . Q
- ; patch HL*1.6*122 end
  ;
  I $P(HLPARM0,U,10) W !,$C(7),"The LLP was last started on ",$$DAT2^HLUTIL1($P(HLPARM0,U,10)),"." G STP1:$P(HLPARM0,U,5)'="Error"
  I $P(HLPARM0,U,11) W !,"The LLP was last shutdown on ",$$DAT2^HLUTIL1($P(HLPARM0,U,11)),"."
- ; patch HL*1.6*122 start
- ; comment out-should be taken care of by the code 2 line above
- ; I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
- ; I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
- ; . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
- N HLTEMP
- S HLTEMP=0
- I $P(HLPARM0,U,12) D  G:HLTEMP STARTQ
- . N ZTSK
- . S ZTSK=$P(HLPARM0,U,12)
- . D STAT^%ZTLOAD
- . I "12"[ZTSK(1) D
- .. W !,$C(7),"NOTE: The lower level protocol for this application is already running."
- .. I '$P(^HLCS(870,HLDP,0),"^",10) S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
- .. S HLTEMP=1
- ; patch HL*1.6*122 end
+ I $P(HLPARM0,U,5)'="Error",'($P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4))),$P(HLPARM0,U,10)]""&($P(HLPARM0,U,11)=""),$P(HLPARM0,U,12) W !,"The LLP appears to be online already !"
+ I $$TASK^HLUTIL1($P(HLPARM0,U,12)) D  G STARTQ
+ . W !,$C(7),"NOTE: The lower level protocol for this application is already running."
  I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)) D  G STARTQ
- .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number
+ .;4=status 9=Time Started, 10=Time Stopped, 11=Task Number 
  .;14=Shutdown LLP, 3=Device Type, 18=Gross Errors
  .N HLJ,X
- . ; patch HL*1.6*122-comment out
- . ; I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
+ .I $P(HLPARM0,U,15)=0 W !,"This LLP is already enabled!" Q
  .L +^HLCS(870,HLDP,0):2
  .E  W !,$C(7),"Unable to enable this LLP !" Q
@@ -84,10 +64,4 @@
  I $P(HLPARM4,U,6),$D(^%ZIS(14.7,+$P(HLPARM4,U,6),0)) S ZTCPU=$P(^(0),U) W !,"This LLP will start on node ",ZTCPU," if it is run in the Background.",!
  ;
- ; patch HL*1.6*122 start, for tcp link
- I HLTYPTR=4 D  Q
- . S Y="B"
- . D STARTJOB
- ; patch HL*1.6*122 end
- ;
  W ! S DIR(0)="SM^F:FOREGROUND;B:BACKGROUND;Q:QUIT"
  S DIR("A")="Method for running the receiver"
@@ -99,10 +73,7 @@
  Q:(Y=U)!(Y="Q")
  ;
-STARTJOB ;
  S HLX=$G(^HLCS(870,HLDP,0))
  ;-- foreground
  I Y="F" S HLTRACE=1 D  G STARTQ
- . S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
- . D MON^HLCSTCP("Start")
  . X HLBGR
  ;-- background
@@ -111,13 +82,8 @@
  . S ZTDESC=HLDAPP_" Low Level Protocol",ZTSAVE("HLDP")=""
  . D ^%ZTLOAD
- . ; patch HL*1.6*122 start
- . I $D(ZTSK) D
- .. K HLTRACE
- .. D MON^HLCSTCP("Tasked")
- .. S $P(^HLCS(870,HLDP,0),"^",10)=$$NOW^XLFDT
- . ; patch HL*1.6*122 end
  . W !,$S($D(ZTSK):"Job was queued as "_ZTSK_".",1:"Unable to queue job.")
  ;
  Q
+ ;
  ;
 STARTQ ;
@@ -132,9 +98,6 @@
  S DIC="^HLCS(870,",DIC(0)="QEAMZ" D ^DIC K DIC Q:Y<0
  S HLDP=+Y,HLDAPP=Y(0,0),HLPARM0=Y(0),HLPARM4=$G(^HLCS(870,HLDP,400))
- ; patch HL*1.6*122
- ; Multi-Servers: TCP service (GT.M, DSM, and Cache/VMS) is controlled
- ; by the external service
  I $P(HLPARM4,U,3)="M",$S(^%ZOSF("OS")'["OpenM":1,1:$$OS^%ZOSV["VMS") D  Q
- . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. TCPIP/UCX. You must use the external service to disable this LLP."
+ . W !,$C(7),"This LLP is a multi-threaded server. It is controlled by external service, i.e. UCX. You must use the external service to disable this LLP."
  . Q
  ;
@@ -150,16 +113,12 @@
  I $P(HLPARM4,U,3)="C"&("N"[$P(HLPARM4,U,4)),'$P(HLPARM0,U,12) S @X@(4)="Shutdown"
  D FILE^HLDIE("","HLJ","","STOP","HLCSLNCH") ; HL*1.6*109
- ; patch HL*1.6*122 start
- ; I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
- ; I ^%ZOSF("OS")'["DSM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
- I ($P(HLPARM4,U,3)="S")!(($P(HLPARM4,U,3)="M")&($S(^%ZOSF("OS")'["OpenM":0,1:$$OS^%ZOSV'["VMS"))) D
+ I ^%ZOSF("OS")["OpenM",(($P(HLPARM4,U,3)="M"&($$OS^%ZOSV'["VMS"))!($P(HLPARM4,U,3)="S")) D
  . ;pass task number to stop listener
  . S:$P(HLPARM0,U,12) X=$$ASKSTOP^%ZTLOAD(+$P(HLPARM0,U,12))
- . ; D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
- . ; I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
- . ; U IO W "**STOP**"
- . ; W !
- . ; D CLOSE^%ZISTCP
- . ; patch HL*1.6*122 end
+ . D CALL^%ZISTCP($P(HLPARM4,U),$P(HLPARM4,U,2),10)
+ . I POP D HOME^%ZIS U IO W !,"Unable to shutdown logical link!!!",$C(7),$C(7) Q
+ . U IO W "**STOP**"
+ . W !
+ . D CLOSE^%ZISTCP
  L -^HLCS(870,HLDP,0)
  W !,"The job for the "_HLDAPP_" Lower Level Protocol will be shut down."
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSMON ;SF-DISPLAY DRIVER PROGRAM  ;12/11/2007  17:07
- ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSMON ;SF-DISPLAY DRIVER PROGRAM  ;07/10/2000  12:18
+ ;;1.6;HEALTH LEVEL SEVEN;**34,40,48,49,65,66,73,109**;Oct 13, 1995
  ;
  ;This Program drives a real-time display monitor for the HL7
@@ -18,9 +17,4 @@
  N HLPARAM,HLPROC,HLPROD,HLSEND,HLSENT,HLSITE
  N HLI,HLREC,HLRUNCNT,HLSTAT,HLTMSTAT,HLLMSTAT,HLVIEW,HLXX,HLYY,X,Y,DX,DY
- ;
- ; patch HL*1.6*122 start
- D HOME^%ZIS
- W @IOF
- ; patch HL*1.6*122 end
  ;
  D ^HLCSTERM ;Sets up variables to control display attributes
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSMON1.m	(revision 636)
@@ -1,5 +1,4 @@
-HLCSMON1 ;SF-Utilities for Driver Program  ;07/17/2007  17:05
- ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSMON1 ;SF-Utilities for Driver Program  ;02/04/2004  10:25
+ ;;1.6;HEALTH LEVEL SEVEN;**15,40,49,65,109**;Oct 13, 1995
  ;
  ;This routine contains several entry points called from HLCSMON
@@ -12,9 +11,5 @@
  F  S HLXX=$O(HLARYD(HLXX)) Q:(HLXX'>0)  D WLINE(HLXX)
  ;DISPLAY INCOMING FILER STATUS
- ; patch HL*1.6*122
- S HLXX=$P(HLRUNCNT,"^",1)
- ; S HLXX=$$CNTFLR^HLCSUTL2("IN")
- I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("IN")
- ;
+ S HLXX=$$CNTFLR^HLCSUTL2("IN")
  ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
  I (HLXX'=+HLRUNCNT) D
@@ -24,9 +19,5 @@
  .S $P(HLRUNCNT,"^",1)=HLXX
  ;DISPLAY OUTGOING FILER STATUS
- ; patch HL*1.6*122
- S HLXX=$P(HLRUNCNT,"^",2)
- ; S HLXX=$$CNTFLR^HLCSUTL2("OUT") 
- I (+HLXX)=-1 S HLXX=$$CNTFLR^HLCSUTL2("OUT")
- ;
+ S HLXX=$$CNTFLR^HLCSUTL2("OUT")
  ;ONLY UPDATE SCREEN IF COUNT HAS CHANGED
  I (HLXX'=+$P(HLRUNCNT,"^",2)) D
@@ -56,18 +47,11 @@
  I HLARYD(HLXX)]"",HLARYD(HLXX)=$G(HLARYO(HLXX)) Q
  S HLARYO(HLXX)=HLARYD(HLXX),HLERR=$P(HLARYD(HLXX),U,8),DX=1
- ; patch HL*1.6*122
- ; F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
- F X=1,7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,10)
- F X=2:1:5 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
- S X=6,@$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,7)
- ;
+ F X=1:1:7 S @$P("HLNODE^HLREC^HLPROC^HLSEND^HLSENT^HLDEV^HLSTAT",U,X)=$E($P(HLARYD(HLXX),U,X)_"        ",1,8)
  ;if link is in error, write node in rev. video
  I HLERR]"" D WDATA(5,HLXX,IOBON_IORVON,IOBOFF_IORVOFF,HLNODE,8) S DX=14
  ;Turn off terminal line wrap & inform O/S where cursor is located
  S DY=HLXX X IOXY,^%ZOSF("XY")
- ; patch HL*1.6*122
- W:HLERR="" ?4,HLNODE
- W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?63,HLSTAT
- ;
+ W:HLERR="" ?5,HLNODE
+ W ?16,HLREC,?26,HLPROC,?37,HLSEND,?47,HLSENT,?58,HLDEV,?64,HLSTAT
  Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSREP.m	(revision 636)
@@ -1,6 +1,4 @@
-HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT ;10/17/2007  08:56
- ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLCSREP ;ALB/MFK - HL7 QUEUE MANAGEMENT - 10/4/94 1pm
+ ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13, 1995
 REPMSG ;Duplicate messages on a queue
  ; INPUT:  MSG   - Array which contains the queue and the
@@ -36,10 +34,5 @@
  I DIR'="I",DIR'="O" Q
  Q:'$G(IEN773)
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T  H 1
  S ^HLMA("AC",DIR,LINK,IEN773)=""
- L -^HLMA("AC",DIR,LINK,IEN773)
- ;
  S $P(^HLMA(+IEN773,0),U,17)=+LINK ; HL*1.6*109 - lja
  I DIR="O" D LLCNT^HLCSTCP(LINK,3)
@@ -56,9 +49,4 @@
  I DIR'="I",DIR'="O" Q
  Q:'$G(IEN773)
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLMA("AC",DIR,LINK,IEN773):10 Q:$T  H 1
  K ^HLMA("AC",DIR,LINK,IEN773)
- L -^HLMA("AC",DIR,LINK,IEN773)
- ;
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP.m	(revision 636)
@@ -1,65 +1,40 @@
-HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/19/2007  10:21
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133,122**;Oct 13, 1995;Build 14
+HLCSTCP ;SFIRMFO/TNV-ALB/JFP,PKE - (TCP/IP) MLLP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,58,64,84,109,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+ ; 
  ; This is an implementation of the HL7 Minimal Lower Layer Protocol
- ; taskman entry/startup option, HLDP defined in menu entry.
- ;
+ ;
+ ;taskman entry/startup option, HLDP defined in menu entry,
  Q:'$D(HLDP)
- ; patch HL*1.6*122 start
- L +^HLCS("HLTCPLINK",HLDP):5 I '$T D  Q
- . D MON^HLCSTCP("TskLcked")
- N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
- N HLZRULE
+ N HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
  ;HLCSOUT= 1-error
  I '$$INIT D EXITS("Init Error") Q
- S HLDP("$J")=$J
- S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
  ; Start the client
  I $G(HLTCPCS)="C" D  Q
- . S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-8+$L(HLTCPORT)+$L(HLDP)
- . I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
- . S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  . ; identify process for ^%SY
- . ; D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
- . D SETNM^%ZOSV($E("HLc:"_HLTCPORT_"-"_HLDP_"-"_HLDP("$J",0),1,15))
- . K HLDP("$J",0)
+ . D SETNM^%ZOSV($E("HLClnt:"_HLDP,1,15))
  . D ST1
  . F  D ^HLCSTCP2 Q:$$STOP!$G(HLCSOUT)
- . ; I $G(HLCSOUT)=1 D MON("Error") H 1 Q
- . I $G(HLCSOUT)=1 D  Q
- .. D MON("Error") H 1
- .. L -^HLCS("HLTCPLINK",HLDP)
+ . I $G(HLCSOUT)=1 D MON("Error") H 1 Q
  . I $G(HLCSOUT)=2 D EXITS("Inactive") Q
  . D EXITS("Shutdown")
  ;
- S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
- I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
- S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  ; identify process for ^%SY
- ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
- D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
- K HLDP("$J",0)
- ; to stop the listener via updated Kernel API, need to pass the
- ; listener logical link (HLDP)
- S HLZRULE="S HLDP="_HLDP_" S ZISQUIT=$$STOP^HLCSTCP"
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
+ ;HLCSFAIL=1 port failed to open
+ S HLCSFAIL=1
  ;single threaded listener
  I $G(HLTCPCS)="S" D  Q
- . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")",HLZRULE)
- . I $$STOP D EXITS("Shutdown") Q
- . D EXITS("Openfail")
- ;
- ;multi-threaded listener (for OpenM/NT)
- I ($G(HLTCPCS)'="M")!(^%ZOSF("OS")'["OpenM") D  Q
- . L -^HLCS("HLTCPLINK",HLDP)
- I $$OS^%ZOSV["VMS" L -^HLCS("HLTCPLINK",HLDP) Q
- D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")",HLZRULE)
- ; update status of listener
- I $$STOP D EXITS("Shutdown") Q
- D EXITS("Openfail")
- ; HL*1.6*122 end
+ . D ST1,MON("Listen"),LISTEN^%ZISTCP(HLTCPORT,"SERVER^HLCSTCP("""_HLDP_""")")
+ . ;couldn't open listener port
+ . I HLCSFAIL D EXITS("Openfail") Q
+ ;
+ ;multi-threaded listener (OpenM)
+ I $G(HLTCPCS)="M",^%ZOSF("OS")["OpenM" D  Q
+ . D ST1,MON("Listen"),LISTEN^%ZISTCPS(HLTCPORT,"SERVERS^HLCSTCP("""_HLDP_""")")
  Q
  ;
 SERVER(HLDP) ; single server using Taskman
+ S HLCSFAIL=0
  I '$$INIT D EXITS("Init error") Q
  D ^HLCSTCP1
@@ -80,18 +55,26 @@
  G LISTEN
  ;
+CACHEVMS(%) ;Cache'/VMS tcpip/ucx entry point, called from HLSEVEN.COM file,
+ ;listener,  % = HLDP
+ I $G(%)="" D ^%ZTER Q
+ S IO="SYS$NET",HLDP=%
+ S IO(0)="_NLA0:" O IO(0) ;Setup null device
+ ; **Cache'/VMS specific code**
+ O IO::5 E  D MON("Openfail") Q
+ X "U IO:(::""-M"")" ;Packet mode like DSM
+ D LISTEN C IO Q
+ ;
+EN ;vms ucx entry point, called from HLSEVEN.COM file,
+ ;listener,  % = device^HLDP
+ I $G(%)="" D ^%ZTER Q
+ S IO="SYS$NET",U="^",HLDP=$P(%,U,2)
+ S IO(0)="_NLA0:" O IO(0) ;Setup null device
+ ; **VMS specific code, need to share device**
+ O IO:(TCPDEV):60 E  D MON("Openfail") Q
 LISTEN ;
- N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET
+ N HLLSTN,HLCSOUT,HLDBACK,HLDBSIZE,HLDREAD,HLDRETR,HLRETRA,HLDWAIT,HLOS,HLTCPADD,HLTCPCS,HLTCPLNK,HLTCPORT,HLTCPRET,HLCSFAIL
  I '$$INIT D ^%ZTER Q
- ; patch HL*1.6*122 start
- S HLDP("$J")=$J
- S HLDP("$J",0,"LENGTH")=$L(HLDP("$J"))
- S HLDP("$J",0,"START")=HLDP("$J",0,"LENGTH")-9+$L(HLTCPORT)
- I HLDP("$J",0,"START")<1 S HLDP("$J",0,"START")=1
- S HLDP("$J",0)=$E(HLDP("$J"),HLDP("$J",0,"START"),HLDP("$J",0,"LENGTH"))
  ; identify process for ^%SY
- ; D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
- D SETNM^%ZOSV($E("HLs:"_HLTCPORT_"-"_HLDP("$J",0),1,15))
- K HLDP("$J",0)
- ; patch HL*1.6*122 end
+ D SETNM^%ZOSV($E("HLSrv:"_HLDP,1,15))
  ;HLLSTN used to identify a listener to tag MON
  S HLLSTN=1
@@ -110,11 +93,9 @@
  S HLOS=$P($G(^%ZOSF("OS")),"^")
  N DA,DIQUIET,DR,TMP,X,Y
- S IOF=$$FLUSHCHR^%ZISTCP ; HL*1.6*122 set device flush character
  S DIQUIET=1
  D DT^DICRW
  I 'HLDP S HLDP=$O(^HLCS(870,"B",HLDP,0)) I 'HLDP Q 0
  S DA=HLDP
- ; patch HL*1.6*122 for field 400.09
- S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05;400.09"
+ S DR="200.02;200.021;200.022;200.03;200.04;200.05;200.09;400.01;400.02;400.03;400.04;400.05"
  D GETS^DIQ(870,DA,DR,"IN","TMP","TMP")
  ;
@@ -144,19 +125,10 @@
  S HLTCPRET=$G(TMP(870,DA_",",400.05,"I"))
  ;
- ; patch HL*1.6*122 for field 400.09
- ; -- tcp/ip openfail timeout
- S HLTCPLNK("TIMEOUT")=$G(TMP(870,DA_",",400.09,"I"))
- ;
  ; -- set defaults in case something's not set
  S:HLDREAD=0 HLDREAD=10
  S:HLDBACK=0 HLDBACK=60
- ; patch HL*1.6*122
- ; S:HLDBSIZE=0 HLDBSIZE=245
- S:HLDBSIZE<245 HLDBSIZE=245
+ S:HLDBSIZE=0 HLDBSIZE=245
  S:HLDRETR=0 HLDRETR=5
  S:HLTCPRET="" X=$P($$PARAM^HLCS2,U,12),HLTCPRET=$S(X:X,1:15)
- ;
- ; patch HL*1.6*122 for field 400.09
- S:HLTCPLNK("TIMEOUT")=0 HLTCPLNK("TIMEOUT")=5
  ;
  Q 1
@@ -166,6 +138,5 @@
  ;14=Shutdown LLP, 3=LLP Online, 18=Gross Errors
  N HLJ,X
- ; HL*1.6*122 remove unnecessary locks
- ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
  S X="HLJ(870,"""_HLDP_","")"
  S @X@(4)="Init",(@X@(10),@X@(18))="@",@X@(14)=0
@@ -175,5 +146,5 @@
  S:$G(ZTSK) @X@(11)=ZTSK
  D FILE^HLDIE("","HLJ","","ST1","HLCSTCP") ;HL*1.6*109
- ;L -^HLCS(870,HLDP,0)
+ L -^HLCS(870,HLDP,0)
  Q
  ;
@@ -181,37 +152,21 @@
  ;don't display for multiple server
  Q:$G(HLLSTN)
- ; HL*1.6*122 remove unnecessary locks
- ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
  S $P(^HLCS(870,HLDP,0),U,5)=Y
- ;L -^HLCS(870,HLDP,0)
+ L -^HLCS(870,HLDP,0)
  Q:'$D(HLTRACE)
  N X U IO(0)
  W !,"IN State: ",Y
  I '$$STOP D
- . ; patch HL*1.6*122
- . ; R !,"Type Q to Quit: ",X#1:1
- . R !,"Type Q to Quit: ",X:1
- . ; I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
- . I $L(X),"Qq"[$E(X) S $P(^HLCS(870,HLDP,0),U,15)=1
- . ; patch HL*1.6*122 end
+ . R !,"Type Q to Quit: ",X#1:1
+ . I $L(X),"Qq"[X S $P(^HLCS(870,HLDP,0),U,15)=1
  U IO
  Q
 UPDT(Y) ;update job count for multiple servers,X=1 increment
  N HLJ,X
- ;
- ; HL*1.6*122 start
- ; F  L +^HLCS(870,HLDP,0):2 Q:$T
- Q:'$G(HLDP)
- Q:'$D(^HLCS(870,"E","M",HLDP))
- F  L +^HLCS(870,HLDP,0):10 Q:$T  H 1
- ; S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
- S X=+$P(^HLCS(870,HLDP,0),U,5)
- I X<0 S X=0
- S $P(^HLCS(870,HLDP,0),U,5)=$S(Y:(X+1),X<1:0,1:X-1)_" server"
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
+ S X=+$P(^HLCS(870,HLDP,0),U,5),$P(^(0),U,5)=$S(Y:X+1,1:X-1)_" server"
  ;if incrementing, set the Device Type field to Multi-Server
- ; I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP")
- I $P(^HLCS(870,HLDP,0),"^",4)']"" S $P(^HLCS(870,HLDP,0),"^",4)="MS"
- ; HL*1.6*122 end
- ;
+ I X S HLJ(870,HLDP_",",3)="MS" D FILE^HLDIE("","HLJ","","UPDT","HLCSTCP") ;HL*1.6*109
  L -^HLCS(870,HLDP,0)
  Q
@@ -230,31 +185,19 @@
  N P,X
  S P=$S(Y<3:"IN",1:"OUT")_" QUEUE "_$S(Y#2:"BACK",1:"FRONT")_" POINTER"
- ; patch HL*1.6*122 start
- ; F  L +^HLCS(870,DP,P):2 Q:$T
- ; S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
- I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
- I OS'["DSM",OS'["OpenM" D
- . F  L +^HLCS(870,DP,P):10 Q:$T  H 1
- . S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
- . L -^HLCS(870,DP,P)
- E  D
- . S X=$I(^HLCS(870,DP,P),$S($G(Z):-1,1:1))
- ; L -^HLCS(870,DP,P)
- ; patch HL*1.6*122 end
+ F  L +^HLCS(870,DP,P):2 Q:$T
+ S X=+$G(^HLCS(870,DP,P)),^(P)=X+$S($G(Z):-1,1:1)
+ L -^HLCS(870,DP,P)
  Q
 SDFLD ; set Shutdown? field to yes
  Q:'$G(HLDP)
- ; HL*1.6*122 remove unnecessary lock and call to FM
- S $P(^HLCS(870,HLDP,0),U,15)=1
- ;N HLJ,X
- ;F  L +^HLCS(870,HLDP,0):2 Q:$T
+ N HLJ,X
+ F  L +^HLCS(870,HLDP,0):2 Q:$T
  ;14=Shutdown LLP?
- ;S HLJ(870,HLDP_",",14)=1
- ;D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
- ;L -^HLCS(870,HLDP,0)
- Q
- ;
-EXITS(Y) ; shutdown and clean up the listener process for either
- ; single-threaded or multi-threaded
+ S HLJ(870,HLDP_",",14)=1
+ D FILE^HLDIE("","HLJ","","SDFLD","HLCSTCP") ;HL*1.6*109
+ L -^HLCS(870,HLDP,0)
+ Q
+ ;
+EXITS(Y) ; Single service shutdown and cleans up
  N HLJ,X
  F  L +^HLCS(870,HLDP,0):2 Q:$T
@@ -266,11 +209,7 @@
  L -^HLCS(870,HLDP,0)
  I $D(ZTQUEUED) S ZTREQ="@"
- ; HL*1.6*122
- L -^HLCS("HLTCPLINK",HLDP)
  Q
  ;
 EXITM ;Multiple service shutdown and clean up
- ; shutdown and clean up a connection spawned by the listener
- ; process for a multi-threaded listener
  D UPDT(0)
  I $D(ZTQUEUED) S ZTREQ="@"
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/17/2007  12:59
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 14
+HLCSTCP1 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;7/28/07  08:58
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,64,71,133,132,122**;OCT 13,1995;Build 4
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;Receiver
@@ -12,18 +12,11 @@
  ; variable to replace ^TMP
  N HLTMBUF
- ;
  ; for HL7 application proxy user
- ;; N HLDUZ,DUZ  ; patch HL*1.6*122 TEST v2: DUZ code removed
- N HLDUZ
- S HLDUZ=+$G(DUZ)
- ;
+ N HLDUZ,DUZ
  D MON^HLCSTCP("Open")
  ; K ^TMP("HLCSTCP",$J,0)
  S HLMIEN=0,HLASTMSG=""
- ;
- ; patch HL*1.6*122 TEST v2: DUZ code removed
  ; set DUZ for application proxy user
- ;; D PROXY^HLCSTCP4
- ;
+ D PROXY^HLCSTCP4
  F  D  Q:$$STOP^HLCSTCP  I 'HLMIEN D MON^HLCSTCP("Idle") H 3
  . ; clean variables
@@ -31,9 +24,6 @@
  . S HLMIEN=$$READ
  . Q:'HLMIEN
- . ;
- . ; patch HL*1.6*122 TEST v2: DUZ code removed
  . ; DUZ comparison/reset for application proxy user
- . ;; D HLDUZ^HLCSTCP4
- . D HLDUZ2^HLCSTCP4
+ . D HLDUZ^HLCSTCP4
  . ; protect HLDUZ 
  . N HLDUZ
@@ -112,5 +102,5 @@
  . I HLBUFF[HLDEND,(HLBUFF("END")=0) S HLBUFF("END")=1
  ; detect disconnect for GT.M
- I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=",UREAD,"
+ I $G(^%ZOSF("OS"))["GT.M",$DEVICE S $ECODE=""
  ; timedout, <clean up>, quit
  ;I '$T,X="",HLX="" S HLACKWT=HLACKWT-HLDREAD D:HLACKWT<0&'HLHDR CLEAN Q
@@ -244,17 +234,6 @@
 SAVE(SRC,DEST) ;save into global & set top node
  ;SRC=source array (passed by ref.), DEST=destination global
- ;
- ; patch HL*1.6*122: MPI-client/server
- I DEST["HLMA" D
- . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
- E  D
- . F  L +^HL(772,+$P(HLIND1,U,2)):10 Q:$T  H 1
- ;
  M @DEST=SRC
  S @DEST@(0)="^^"_HLINE_"^"_HLINE_"^"_DT_"^"
- ;
- I DEST["HLMA" L -^HLMA(+HLIND1)
- E  L -^HL(772,+$P(HLIND1,U,2))
- ;
  Q
  ;
@@ -277,7 +256,11 @@
  ;
 ERROR ; Error trap for disconnect error and return back to the read loop.
- ; patch HL*1.6*122
- ; move to routine HLCSTCP4 (splitted-size over 10000)
- D ERROR1^HLCSTCP4
+ S $ETRAP="D UNWIND^%ZTER"
+ I $$EC^%ZOSV["IOEOF" D UNWIND^%ZTER Q  ;VOE change for GT.M
+ I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
+ I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
+ I $ECODE["UREAD" D UNWIND^%ZTER Q  ; HL*1.6*122 GT.M
+ S HLCSOUT=1 D ^%ZTER,CC("Error")
+ D UNWIND^%ZTER
  Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/17/2007  09:37
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133,122**;Oct 13,1995;Build 14
+HLCSTCP2 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,49,57,63,64,66,67,76,77,87,109,133**;Oct 13,1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;Sender 
@@ -11,10 +11,7 @@
  S HLTCPO=HLDP,HLMSG="",(HLRETRY,HLRETMG)=0
  ;
- ; patch 122
- ; patch 133
- ; set IO(0) to the null device
- I $G(^%ZOSF("OS"))]"",^%ZOSF("OS")'["GT.M" D
- . S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
- . O IO(0) U IO(0)
+ ;set IO(0) to the null device
+ S IO(0)=$S(^%ZOSF("OS")["OpenM":$S($$OS^%ZOSV()["VMS":"_NLA0:",$$OS^%ZOSV()["UNIX":"/dev/null",1:$P),^%ZOSF("OS")["DSM":"_NLA0:",1:$P)
+ O IO(0) U IO(0)
  ;
  ;persistent conection, open connection first, HLPORT=open port
@@ -39,21 +36,16 @@
  ; and then check the link if it open or not
  N HL,HLN,HLARR,HLHDR,HLI,HLJ,HLMSA,HLRESP,HLRESLT,HLRETRM,HLTCP,HLTCPI,X,Z,HLREREAD
- N HLTMBUF
- D MON^HLCSTCP("CheckOut")
+ D MON^HLCSTCP("Check out")
  ;HLMSG=next msg, set at tag DONE
  I 'HLMSG S HLMSG=+$O(^HLMA("AC","O",HLDP,0)),HLRETRY=0 Q:'HLMSG
  ;
+ ;**109**
+ ;Temporarily lock ^HLMA to flush buffer and ensure edits are complete
+ ;L +^HLMA(HLMSG):1 I '$T S HLMSG=0 Q
+ ;L -^HLMA(HLMSG)
+ ;
  S HLI=+$G(^HLMA(HLMSG,0)),HLJ=$O(^("MSH",0)),HLTCP=""
  ;don't have message text or MSH, kill x-ref and decrement 'to send'
- ;
- ; patch HL*1.6*122: MPI-client/server
- ; I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
- I 'HLI!'HLJ D  Q
- . F  L +^HLMA("AC","O",HLDP,HLMSG):10 Q:$T  H 1
- . K ^HLMA("AC","O",HLDP,HLMSG)
- . L -^HLMA("AC","O",HLDP,HLMSG)
- . D LLCNT^HLCSTCP(HLDP,3,1)
- . S HLMSG=0
- ;
+ I 'HLI!'HLJ K ^HLMA("AC","O",HLDP,HLMSG) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
  ;update msg status to 'being transmitted'; if cancelled decrement link and quit
  I '$$CHKMSG(1.5) D LLCNT^HLCSTCP(HLDP,3,1) S HLMSG=0 Q
@@ -153,6 +145,4 @@
  ; Set up error trap
  N $ETRAP,$ESTACK S $ETRAP="D ERROR^HLCSTCP2"
- ; patch HL*1.6*122
- N HLTMBUF
  ;override ack timeout
  I $G(HLP("ACKTIME")) N HLDBACK S HLDBACK=HLP("ACKTIME")
@@ -179,4 +169,5 @@
  D STATUS^HLTF0(HLMSG,ST,$G(ERR),$G(ERRMSG),1)
  ;
+ ;**109**
  D DEQUE^HLCSREP(HLDP,"O",HLMSG)
  ;
@@ -189,4 +180,8 @@
  ;returns 1=msg was updated, 0=msg has been canceled
  N X
+ ;
+ ;**109**
+ ;F  L +^HLMA(HLMSG,"P"):1 Q:$T  H 1
+ ;
  ;
  ; New HL*1.6*77 code starting here...
@@ -195,14 +190,22 @@
  .  D STATUS^HLTF0(HLMSG,4,$P(HLERROR,U),$P(HLERROR,U,2),1)
  .;
+ .;**109**
  . D DEQUE^HLCSREP(HLDP,"O",HLMSG)
- ;
- ; End of HL*1.6*77
+ .;L -^HLMA(HLMSG,"P")
+ ;**end 109**
+ ;
+ ; End of HL*1.6*77 modifications
  ;
  ;get status, quit if msg was cancelled
  ;
+ ;**109**
+ ;S X=+^HLMA(HLMSG,"P") I X=3 L -^HLMA(HLMSG,"P") Q 0
  S X=+^HLMA(HLMSG,"P") Q:X=3 0
  ;
  ;update status if it is different
  I $G(HLI),HLI'=X D STATUS^HLTF0(HLMSG,HLI)
+ ;
+ ;**109**
+ ;L -^HLMA(HLMSG,"P")
  ;
  Q 1
@@ -216,6 +219,5 @@
  ;           -1 - Unsuccessful
  ;
- N HLDA2,HLAR,HLI,LINENO,X,CRCOUNT
- S CRCOUNT=0
+ N HLDA2,HLAR,HLI,LINENO,X
  ;set error trap, used when called from HLTP3
  ;
@@ -235,29 +237,12 @@
  .. ;first line, need start block char.
  .. S:LINENO=1 X=$C(11)_X
- .. ; HL*1.6*122
- .. ; I X]"" W X,!
- .. N LENGTH
- .. S LENGTH=$L(X)
- .. ; buffer should be limited to 512
- .. I LENGTH>512 D
- ... N X1
- ... F  Q:LENGTH<512  D
- .... S X1=$E(X,1,512),X=$E(X,513,999999)
- .... S LENGTH=$L(X)
- .... W X1,@IOF
- .. ;
- .. ; @IOF (! or #) for flush character
- .. I X]"" W X,@IOF S CRCOUNT=0
- .. ;send CR
- .. I X="" W $C(13) S CRCOUNT=CRCOUNT+1
- .. ; prevent from maxstring error
- .. I CRCOUNT>200 W @IOF S CRCOUNT=0
+ .. I X]"" W X,!
+ .. ;send CR for blank lines
+ .. I X="" W $C(13)
  .. S LINENO=LINENO+1
  ; Sends end block for this message
  S X=$C(28)_$C(13)
- ; U IO W X,!
- U IO W X,@IOF
- ;switch to null device
- I $G(IO(0))'="",$G(IO(0))'=IO U IO(0)
+ U IO W X,!
+ I $G(IO(0))'="",$G(IO(0))'=IO U IO(0) ;switch to null device if opened to prevent 'leakage'
  Q 1
  ;
@@ -271,6 +256,6 @@
  G OPENA^HLCSTCP3
  ;
-RDERR D RDERR^HLCSTCP4 Q
-ERROR D ERROR^HLCSTCP4 Q
+RDERR D RDERR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
+ERROR D ERROR^HLCSTCP4 Q  ; Exceeded 10,000 bytes, so split on 12/2/03-LJA
  ;
 CC(X) ;cleanup and close
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP3.m	(revision 636)
@@ -1,54 +1,16 @@
-HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ; 09/13/2006  15:36
- ;;1.6;HEALTH LEVEL SEVEN;**76,77,133,122**;OCT 13, 1995;Build 14
+HLCSTCP3 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**76,77,133**;OCT 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
-OPENA ;
- ; called from $$OPEN^HLCSTCP2 and this sub-routine OPENA
- ;
- I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+OPENA I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S HLPORTA=+$P(^("P"),U,6)
+ D MON^HLCSTCP("Open")
  S POP=1
- ;
- ; patch HL*1.6*122 start
- ; variable HLDRETR=re-transmit attemps (#870,200.02)
- ; variable HLTCPLNK("TIMEOUT")=timeout for 3rd parameter of CALL^%ZISTCP()
- ; defined in HLCSTCP routine
- ;
- I '$G(HLDRETR("COUNT")) S HLDRETR("COUNT")=1
- I '$G(HLTCPLNK("TIMEOUT")) S HLTCPLNK("TIMEOUT")=5
- S HLDRETR("COUNT-2")=HLDRETR("COUNT")+HLDRETR
- ; patch 133
- ; I $G(HLDIRECT("OPEN TIMEOUT")) D
- ; .S HLI=1
- ; .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
- ; E  D
- ; .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
  I $G(HLDIRECT("OPEN TIMEOUT")) D
- . D MON^HLCSTCP("Open")
- . D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
- . ; give site one more chance to override the application setup
- . I $G(POP),(HLTCPLNK("TIMEOUT")>HLDIRECT("OPEN TIMEOUT")) D
- .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
+ .S HLI=1
+ .D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLDIRECT("OPEN TIMEOUT"))
  E  D
- . N COUNT
- . ; try to connect HLDRETR times
- . F HLDRETR("COUNT")=HLDRETR("COUNT"):1:HLDRETR("COUNT-2") D  Q:('POP)!($$STOP^HLCSTCP)
- .. D MON^HLCSTCP("Open")
- .. ; D CALL^%ZISTCP(HLTCPADD,HLTCPORT)
- .. D CALL^%ZISTCP(HLTCPADD,HLTCPORT,HLTCPLNK("TIMEOUT"))
- .. ;open error
- .. I POP D
- ... D CC^HLCSTCP2("Openfail")
- ... H $S(HLDRETR("COUNT")=1:0,HLDRETR("COUNT")<10:1,1:8)
- ... I '$D(^XTMP("HL7-Openfail",$J)) D
- .... S ^XTMP("HL7-Openfail",0)=$$FMADD^XLFDT($$NOW^XLFDT,3)_"^"_$$NOW^XLFDT
- .... S ^XTMP("HL7-Openfail",$J,"COUNT","FIRST")=HLDRETR("COUNT")_"^"_$$NOW^XLFDT
- ... S COUNT=$P($G(^XTMP("HL7-Openfail",$J,"COUNT","LAST")),"^")+1
- ... S ^XTMP("HL7-Openfail",$J,"COUNT","LAST")=COUNT_"^"_$$NOW^XLFDT
- ;
+ .F HLI=1:1:HLDRETR D CALL^%ZISTCP(HLTCPADD,HLTCPORT) Q:'POP
  ;set # of opens back in msg
- ; I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
- I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLDRETR("COUNT")
- ; patch HL*1.6*122 end
- ;
+ I $G(HLMSG),$D(^HLMA(HLMSG,"P")) S $P(^("P"),U,6)=HLPORTA+HLI
  ;device open
  I 'POP S HLPORT=IO D  Q $S($G(HLERROR)]"":0,1:1)
@@ -61,26 +23,14 @@
  . U IO W "HELO "_$$KSP^XUPARAM("WHERE"),! R X:1
  ;openfail-try DNS lookup
- ;
- ; patch HL*1.6*122 start
- ;I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
- I '$D(HLDOM) D
- . S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U)
- . S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
- . D:HLDOM]""!($L(HLDOM("DNS"),".")>2) DNS
- ;
- Q:$$STOP^HLCSTCP 0
+ I '$D(HLDOM) S HLDOM=+$P(^HLCS(870,HLDP,0),U,7),HLDOM=$P($G(^DIC(4.2,HLDOM,0)),U) D:HLDOM]"" DNS
  ;HLIP=ip add. from DNS call, get first one and try open again
  I $D(HLIP) S HLTCPADD=$P(HLIP,","),HLIP=$P(HLIP,",",2,99) G:HLTCPADD OPENA
- ; open error
- ;cleanup and close
- ; patch 133
+ ;open error
  I $G(HLDIRECT("OPEN TIMEOUT")) D
- . D MON^HLCSTCP("Openfail")
- . I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
+ .D MON^HLCSTCP("Openfail")
+ .I $D(HLPORT) D CLOSE^%ZISTCP K HLPORT
  E  D
- . D CC^HLCSTCP2("Openfail")
+ .D CC^HLCSTCP2("Openfail") H 3
  Q 0
- ; patch HL*1.6*122 end
- ;
  ;
  ;following code was removed, site's complained of to many alerts
@@ -107,10 +57,4 @@
  I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
  I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
- ;
- ; patch HL*1.6*122 start
- I $L($G(HLDOM("DNS")),".")>2 D
- . S HLDOM=HLDOM("DNS")
- ; patch HL*1.6*122 end
- ;
  S HLIP=$$ADDRESS^XLFNSLK(HLDOM)
  K:HLIP="" HLIP
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCP4.m	(revision 636)
@@ -1,4 +1,4 @@
-HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;10/18/2007  09:56
- ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
+HLCSTCP4 ;SFIRMFO/RSD - BI-DIRECTIONAL TCP ;11/03/2006  13:31
+ ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 4
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -15,69 +15,35 @@
  ;I $G(HLMSG) L -^HLMA(HLMSG)
  ;
- ; patch HL*1.6*122 start
- N STOP
- S STOP=0
- I $G(HLDP) S STOP=$$STOP^HLCSTCP
  S $ETRAP="D UNWIND^%ZTER"
- S HLTCP("$ZA\8192#2")=""
- I (^%ZOSF("OS")["OpenM") D
- . S HLTCP("$ZA")=$ZA
- . ; For TCP devices $ZA\8192#2: the device is currently in the
- . ; Connected state talking to a remote host.
- . S HLTCP("$ZA\8192#2")=$ZA\8192#2
- ;
+ ; patch HL*1.6*122
+ S HLTCPERR("$P")=$P
  S HLTCPERR("ERR-$ZE")=$$EC^%ZOSV
  ; I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D CC^HLCSTCP2("Op-err") S:$G(HLPRIO)="I" HLERROR="15^Open Related Error" D UNWIND^%ZTER Q
- I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  G:STOP H2^XUSCLEAN Q
- . D CC^HLCSTCP2("Op-err") H 1
+ I $$EC^%ZOSV["OPENERR"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
+ . D CC^HLCSTCP2("Op-err")
  . S:$G(HLPRIO)="I" HLERROR="15^Open Related Error"
- . I STOP D  Q
- .. D CC^HLCSTCP2("Shutdown: (with 'Op-err')")
- . I 'STOP D UNWIND^%ZTER
- I $$EC^%ZOSV["WRITE" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
- . D CC^HLCSTCP2("Wr-err") H 1
- . S:$G(HLPRIO)="I" HLERROR="108^Write Error"
- . I STOP D  Q
- .. D CC^HLCSTCP2("Shutdown: (with 'Wr-err')")
- . I HLTCP("$ZA\8192#2")=0 D  Q
- .. D CC^HLCSTCP2("Halt (Wr): (Disconnected with 'Wr-err')")
- . I 'STOP,HLTCP("$ZA\8192#2") D UNWIND^%ZTER
+ . D UNWIND^%ZTER
+ I $$EC^%ZOSV["WRITE" D  Q  ;HL*1.6*77 modifications start here
+ .  D CC^HLCSTCP2("Wr-err")
+ .  S:$G(HLPRIO)="I" HLERROR="108^Write Error"
+ .  D UNWIND^%ZTER ;HL*1.6*77 modifications end here
  ; I $$EC^%ZOSV["READ" D CC^HLCSTCP2("Rd-err") S:$G(HLPRIO)="I" HLERROR="108^Read Error" D UNWIND^%ZTER Q
- I $$EC^%ZOSV["READ" D  G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN Q
- . D CC^HLCSTCP2("Rd-err") H 1
+ I $$EC^%ZOSV["READ" D  Q
+ . D CC^HLCSTCP2("Rd-err")
  . S:$G(HLPRIO)="I" HLERROR="108^Read Error"
- . I STOP D  Q
- .. D CC^HLCSTCP2("Shutdown: (with 'Rd-err')")
- . I HLTCP("$ZA\8192#2")=0 D  Q
- .. D CC^HLCSTCP2("Halt (Rd): (Disconnected with 'Rd-err')")
- . I 'STOP,HLTCP("$ZA\8192#2") D UNWIND^%ZTER
+ . D UNWIND^%ZTER
  S HLCSOUT=1 D ^%ZTER,CC^HLCSTCP2("Error"),SDFLD^HLCSTCP
  S:$G(HLPRIO)="I" HLERROR="9^Error"
- I STOP D CC^HLCSTCP2("Shutdown: (with 'Error')")
- I HLTCP("$ZA\8192#2")=0 D
- . D CC^HLCSTCP2("Halt (Er): (Disconnected with 'Error')")
- G:STOP!(HLTCP("$ZA\8192#2")=0) H2^XUSCLEAN
- ; patch HL*1.6*122 end
  D UNWIND^%ZTER
  Q
  ;
 PROXY ; set DUZ for application proxy user
- ;
- ; removed the execcution: patch 122 TEST v2
+ S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
+ S DUZ=HLDUZ
+ D DUZ^XUP(DUZ)
  Q
  ;
- ;; S HLDUZ=+$$APFIND^XUSAP("HLSEVEN,APPLICATION PROXY")
- ;; S DUZ=HLDUZ
- ;; D DUZ^XUP(DUZ)
- ;; Q
- ;
 HLDUZ ; compare DUZ and set DUZ to application proxy user
- ;
- ; removed the execcution: patch 122 TEST v2
- Q
- ;
- ;; I '$G(HLDUZ) D PROXY
- ;
-HLDUZ2 ; compare DUZ and HLDUZ
+ I '$G(HLDUZ) D PROXY
  I $G(DUZ)'=HLDUZ D
  . S DUZ=HLDUZ
@@ -121,10 +87,5 @@
  I HLIND1 D  Q
  . ;get pointer to 772, kill header
- . ;
- . ; patch HL*1.6*122: MPI-client/server
- . F  L +^HLMA(+HLIND1):10 Q:$T  H 1
  . K ^HLMA(+HLIND1,"MSH")
- . L -^HLMA(+HLIND1)
- . ;
  . I $D(^HL(772,+$P(HLIND1,U,2),"IN")) K ^("IN")
  . S X=$$MAID^HLTF(+HLIND1,HLMID)
@@ -155,64 +116,2 @@
  Q X
  ;
-ERROR1 ;
- ; moved from ERROR^HLCSTCP1
- ; Error trap for disconnect error and return back to the read loop.
- ; patch HL*1.6*122 start
- I (^%ZOSF("OS")["OpenM") D
- . S HLTCP("$ZA")=$ZA
- . ; For TCP devices $ZA\8192#2: the device is currently in the
- . ; Connected state talking to a remote host.
- . S HLTCP("$ZA\8192#2")=$ZA\8192#2
- . I HLTCP("$ZA\8192#2")=0 D
- .. ; decrement counter of multi-listener
- .. I $D(^HLCS(870,"E","M",+$G(HLDP))) D EXITM^HLCSTCP
- .. ; process terminated
- .. D H2^XUSCLEAN
- S $ETRAP="D UNWIND^%ZTER"
- ; I $$EC^%ZOSV["READ"!($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D UNWIND^%ZTER Q
- I ($$EC^%ZOSV["NOTOPEN")!($$EC^%ZOSV["DEVNOTOPN") D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Open-err")
- . D UNWIND^%ZTER
- I $$EC^%ZOSV["READ" D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
- . D UNWIND^%ZTER
- ;
- ; I $$EC^%ZOSV["WRITE" D CC("Wr-err") D UNWIND^%ZTER Q
- I $$EC^%ZOSV["WRITE" D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Wr-err")
- . D UNWIND^%ZTER
- ;
- ; for GT.M
- I $ECODE["UREAD" D  Q
- . ; if it is not a multi-listener
- . I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Rd-err")
- . D UNWIND^%ZTER
- ;
- ; S HLCSOUT=1 D ^%ZTER,CC("Error")
- S HLCSOUT=1
- D ^%ZTER
- ; if it is not a multi-listener
- I '$D(^HLCS(870,"E","M",+$G(HLDP))) D CC^HLCSTCP1("Error")
- ; patch HL*1.6*122 end
- ;
- D UNWIND^%ZTER
- Q
- ;
-CLRMCNTR ;
- ; clear the counter to set as "0 server" for multi-listener
- ; HL*1.6*122 start
- Q:'$G(HLDP)
- Q:'$D(^HLCS(870,"E","M",HLDP))
- S $P(^HLCS(870,HLDP,0),"^",4)="MS"
- S $P(^HLCS(870,HLDP,0),U,5)="0 server"
- Q
- ;
-CREATUSR ;
- ; patch HL*1.6*122 TEST v2: DUZ code removed
- ; create application proxy users for listeners and incoming filer
- ;; N HLTEMP
- ;; S HLTEMP=$$CREATE^XUSAP("HLSEVEN,APPLICATION PROXY","#")
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTCPA.m	(revision 636)
@@ -1,37 +1,23 @@
-HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/26/2007  10:29
- ;;1.6;HEALTH LEVEL SEVEN;**84,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLCSTCPA ;OIFO-O/RJH - (TCP/IP) VMS ;07/10/2003  10:12
+ ;;1.6;HEALTH LEVEL SEVEN;**84**;Oct 13, 1995
  ;
- ; 1. port number is input from VMS COM file, such as HLSxxxxDSM.COM,
- ;    HLSxxxxCACHE.COM, or HLSxxxxGTM.COM file, where xxxx is port
- ;    number.
- ; 2. find the ien of #870(logical link file) for the multi-listener
+ ; 1. port number is input from VMS HLSxxxxDSM.COM or HLSxxxxCACHE.COM
+ ;    file, where xxxx is port number.
+ ; 2. find the ien of #870(logical link file) for the HL7 multi-listener
+ ; 3. call the appropriate entry:
+ ;    for Cache: CACHEVMS^HLCSTCP(ien of #870)
+ ;    for DSM:   EN^HLCSTCP
  Q
+PORT ;
+ ;HLIEN870: ien in #870 (logical link file)
+ ;HLPORT: port number of multi-listener
+ ;HLPRTS: port number in entry to be tested
+ ;input of DSM: % = device^port number of multi-listener
+ ;input of Cache: port number of TCPIP
  ;
-GTMPORT(%) ; From tcpip ZFOO for GT.M
- ; %: device^port number
- N HLPORT
- S HLPORT=$P($G(%),"^",2)
- I $G(^%ZOSF("OS"))'["GT.M" D ^%ZTER Q
- D IEN
- Q
- ;
-PORT ;
- ; HLPORT: port number of multi-listener
- ; input of DSM: % = device^port number of multi-listener
- ; input of Cache: port number of TCPIP
- ;
- N HLPORT
- S HLPORT=0
  I ^%ZOSF("OS")["OpenM" D
  . S HLPORT=$ZF("GETSYM","PORT")
  I ^%ZOSF("OS")["DSM" D
  . S HLPORT=$P(%,"^",2)
- ;
-IEN ;
- ; HLIEN870: ien in #870 (logical link file)
- ; HLPRTS: port number in entry to be tested
- ;
- N HLIEN870
  I 'HLPORT D ^%ZTER Q
  S HLIEN870=0
@@ -41,10 +27,8 @@
  ;
  K HLPORT,HLPRTS
- ; patch 122
- S U="^"
  ;
  ;for Cache/VMS
  I ^%ZOSF("OS")["OpenM" D  Q
- . D CACHEVMS(HLIEN870)
+ .D CACHEVMS^HLCSTCP(HLIEN870)
  ;
  ;for DSM
@@ -52,62 +36,6 @@
  . S $P(%,"^",2)=HLIEN870   ;set % = device^ien of #870
  . K HLIEN870
- . D EN
- ;
- ;for GT.M
- I ^%ZOSF("OS")["GT.M" D  Q
- . S HLDP=HLIEN870   ;set HLDP = ien of #870
- . K HLIEN870
- . D GTMUCX
+ . D EN^HLCSTCP
  ;
  D ^%ZTER
  Q
-GTMUCX ; GT.M /VMS tcpip
- ;listener,  % = device^port
- S U="^",IO=$P(%,U)
- ; S IO(0)=$P O IO(0) ;Setup null device
- ; GTM specific code
- S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- X "O IO:(RECORDSIZE=512)"
- D LISTEN^HLCSTCP
- C IO
- Q
- ;
- ; $ x=f$trnlnm("sys$net")  !This is our MBX device
- ; $!
- ; $! for GT.M
- ; $ assign 'f$trnlnm("SYS$NET")' SYS$NET
- ; $! Depending on how your command files are set up, you may need to
- ; $! run the GT.M profile file.
- ; $ @<user$:[gtmmgr]>gtmprofile.com
- ; $ forfoo="$" + f$parse("user$:[gtmmgr.r]ZFOO.exe")
- ; $ PORT=5000
- ; $ data="''x'^''PORT'"
- ; $ forfoo GTMPORT^HLCSTCPA("''data'")
- ;
-CACHEVMS(%) ;Cache'/VMS tcpip
- ;listener,  % = HLDP
- I $G(%)="" D ^%ZTER Q
- ; patch 133
- S IO="SYS$NET",U="^",HLDP=%
- S IO(0)="_NLA0:" O IO(0) ;Setup null device
- ; **Cache'/VMS specific code**
- O IO::5 E  D MON^HLCSTCP("Openfail") Q
- X "U IO:(::""-M"")" ;Packet mode like DSM
- D LISTEN^HLCSTCP
- C IO
- Q
- ;
-EN ; DSM/VMS tcpip
- ;listener,  % = device^HLDP
- I $G(%)="" D ^%ZTER Q
- ; patch 122
- ; S IO="SYS$NET",U="^",HLDP=$P(%,U,2)
- S U="^",IO=$P(%,U),HLDP=$P(%,U,2)
- ; patch 133
- S IO(0)="_NLA0:" O IO(0) ;Setup null device
- ; **VMS specific code, need to share device**
- O IO:(TCPDEV):60 E  D MON^HLCSTCP("Openfail") Q
- ; patch 122
- D LISTEN^HLCSTCP
- C IO
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLCSTERM.m	(revision 636)
@@ -1,6 +1,4 @@
-HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES ;06/27/2007  17:04
- ;;1.6;HEALTH LEVEL SEVEN;**40,49,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLCSTERM ;ALB/RJS - SET UP VIDEO ATTRIBUTES - 8/1/94 ;07/28/98  09:43
+ ;;1.6;HEALTH LEVEL SEVEN;**40,49**;Oct 13, 1995
 TERM ; -- set up term characteristics
  N X
@@ -25,8 +23,5 @@
  D WDATA^HLCSMON1(37,3,"","","MESSAGES",8),WDATA^HLCSMON1(37,4,IOUON,IOUOFF,"TO SEND ",8)
  D WDATA^HLCSMON1(47,3,"","","MESSAGES",8),WDATA^HLCSMON1(47,4,IOUON,IOUOFF,"SENT    ",8)
- ; patch HL*1.6*122
- ; D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",8)
- D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",6)
- ;
+ D WDATA^HLCSMON1(57,3,"","","DEVICE",8),WDATA^HLCSMON1(57,4,IOUON,IOUOFF,"TYPE   ",8)
  D WDATA^HLCSMON1(66,4,IOUON,IOUOFF,"STATE",8)
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLDIE.m	(revision 636)
@@ -1,6 +1,4 @@
-HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 10/19/2007 11:15
- ;;1.6;HEALTH LEVEL SEVEN;**109,122**;Oct 13,1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- Q
+HLDIE ;CIOFO-O/LJA - Direct 772 & 773 Sets ; 11/18/2003 11:17
+ ;;1.6;HEALTH LEVEL SEVEN;**109**;Oct 13,1995
  ;
  ; Rules: if any of these rules is broken, FILE^DIE is called instead
@@ -75,12 +73,6 @@
  .I FILE=772 D DEL772^HLUOPT3(+IEN)
  ;
- ; patch HL*1.6*122: MPI-client/server
  ; If no data in record passed in, log an error and quit...
- ; I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
- N HLDGBL
- F  L +@GBL:10 Q:$T  H 1
- S HLDGBL=$D(@GBL)
- L -@GBL
- I 'HLDGBL D  Q  ; Remember.  GBL contains IEN...
+ I '$D(@GBL) D  Q  ; Remember.  GBL contains IEN...
  .  S ERRNO=$$ERRNO(601,"The entry does not exist.",FILE,2)
  .  S @ERR@("DIERR",+ERRNO,"PARAM","IENS")=IEN_$S(IEN'[",":",",1:"")
@@ -118,10 +110,4 @@
  QUIT:'$D(NODE("CHG"))  ;->
  ;
- ; patch HL*1.6*122: MPI-client/server
- I FILE=773 D
- . F  L +^HLMA(IEN):10 Q:$T  H 1
- E  D
- . F  L +^HL(772,IEN):10 Q:$T  H 1
- ;
  ; Store changes in the global now...
  D STORE(FILE,IEN,.NODE)
@@ -131,8 +117,4 @@
  F  S XRF=$O(XRF(XRF)) Q:XRF']""  D
  .  D @("XRF"_XRF_U_ROUTINE)
- ;
- ; patch HL*1.6*122: MPI-client/server
- I FILE=773 L -^HLMA(IEN)
- E  L -^HL(772,IEN)
  ;
  Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLFNC.m	(revision 636)
@@ -1,6 +1,4 @@
-HLFNC ;AISC/SAW/OAK-OIFO/RBN-Routine of Functions and Other Calls Used for HL7 Messages  ;03/26/2008  11:34
- ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66,141**;Oct 13, 1995;Build 11
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLFNC ;AISC/SAW-Routine of Functions and Other Calls Used for HL7 Messages ;08/03/2000  15:45
+ ;;1.6;HEALTH LEVEL SEVEN;**38,42,51,66**;Oct 13, 1995
 HLNAME(X,HLECDE) ;Convert a name in DHCP format to HL7 format
  ; INPUT: X - Name in DHCP format
@@ -55,5 +53,5 @@
  Q $S(Y="DT":$E(%,1,8),1:%)
  ;
-FMDATE(X) ; Convert a date, date/time or time only in HL7 format to FM format
+FMDATE(X) ;Convert a date, date/time or time only in HL7 format to FM format
  I X="" Q ""
  N %
@@ -160,20 +158,5 @@
  Q:'$D(X) ""  Q:$L(X)<7 ""
  N I,Y,Y1,Z S B=$S('$D(B):"",1:"B"_B),C=$S('$D(C):"",1:"C"_C)
- ;
- ; patch HL*1.6*141 start
- ; S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
- N CH
- S Y=""
- F I=1:1:$L(X) D
- . S CH=$E(X,I)
- . ; Next line modified by RBN
- . ;S Y=Y_$S(CH?1N:CH,"Xx"[CH&('$D(Z)):"X",1:"")
- . S Y=Y_$S(CH?1N:CH,"Xx,*"[CH&('$D(Z)):"X",1:"")
- . I "Xx"[CH S Z=""
- ;
- ; the number, following "X" character, should be greater than 0
- I Y["X",+$P(Y,"X",2)<1 S Y=$P(Y,"X")
- ; patch HL*1.6*141 end
- ;
+ S Y="" F I=1:1:$L(X) S Y=Y_$S($E(X,I)?1N:$E(X,I),"X,x"[$E(X,I)&('$D(Z)):"X",1:"") I "X,x"[$E(X,I) S Z=""
  I $L(Y)<7 Q ""
  S Y1=$S(Y["X":"X"_$P(Y,"X",2),1:""),Y=$P(Y,"X") I $L(Y)<7 Q ""
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLMA.m	(revision 636)
@@ -1,4 +1,4 @@
-HLMA ;AISC/SAW-Message Administration Module ;10/24/2007  10:15
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132,122**;Oct 13, 1995;Build 14
+HLMA ;AISC/SAW-Message Administration Module ;10/25/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,58,63,66,82,91,109,115,133,132**;Oct 13, 1995;Build 6
  ;Per VHA Directive 2004-038, this routine should not be modified.
 GENERATE(HLEID,HLARYTYP,HLFORMAT,HLRESLT,HLMTIEN,HLP) ;
@@ -35,7 +35,5 @@
  ;   HLP("CONTPTR") = Continuation pointer, a 1 to 180 character string
  ; HLP("NAMESPACE") = Passed in by application namespace - HL*1.6*91
- ; HLP("EXCLUDE SUBSCRIBER",<n=1,2,3...>)=<subscriber protocol ien> or
- ;   <subscriber protocol name> - A list of protocols to dynamically
- ;   drop from the event protocol's subscriber multiple.
+ ; HLP("EXLCLUDE SUBSCRIBER",<n=1,2,3...>)=<subsciber protocol ien> - A list of protocols to dynamically drop from the event protocol's subscriber multiple.
  ;
  ;can't have link open when generating new message
@@ -44,7 +42,5 @@
  S HLRESLT=""
  ;Check for required parameters
-CONT ;
- I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") D  G EXIT
- . S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point"
+CONT I $G(HLEID)']""!($G(HLARYTYP)']"")!($G(HLFORMAT)']"") S HLRESLT="0^7^"_$G(^HL(771.7,7,0))_" at GENERATE^HLMA entry point" G EXIT
  I 'HLEID S HLEID=$O(^ORD(101,"B",HLEID,0)) I 'HLEID S HLRESLT="0^1^"_$G(^HL(771.7,1,0)) G EXIT
  N HLRESLT1,HLRESLTA S (HLRESLTA,HLRESLT1)=""
@@ -82,9 +78,4 @@
  I HLMIDAR K HLMIDAR("N") M HLRESLT=HLMIDAR
  S HLRESLT=HLRESLT_"^"_HLRESLT1
- ;
- ; patch HL*1.6*122
- S HLRESLT("HLMID")=$G(HLMIDAR("HLMID"))
- S HLRESLT("IEN773")=$G(HLMIDAR("IEN773"))
- ;
  ;Execute exit action for event driver protocol
  I HLEXROU]"" X HLEXROU
@@ -97,11 +88,9 @@
  ;Entry point to generate an immediate message, must be TCP Logical Link
  ;Input:
- ;  The same as GENERATE,with one additional subscript to the HLP input 
- ;  array:
+ ;  The same as GENERATE,with one additional subscript to the HLP input array:
  ; 
  ;  HLP("OPEN TIMEOUT") (optional, pass by reference) a number between 
  ;    1 and 120 that specifies how many seconds the DIRECT CONNECT should
- ;    try to open a connection before failing.  It is killed upon 
- ;    completion.
+ ;    try to open a connection before failing.  It is killed upon completion.
  ; 
  N HLTCP,HLTCPO,HLPRIO,HLSAN,HLN,HLMIDAR,HLMTIENR,ZMID,HLDIRECT
@@ -137,6 +126,4 @@
  ;I $P($G(^HLCS(870,HLDP,400)),U)="" W !,"Missing IP Address" Q
  D SETUP^HLCSAC G:HLCS PINGQ
- ; patch HL*1.6*122
- G:$$DONTPING^HLMA4 PINGQ
  ;PING header=MSH^PING^domain^PING^logical link^datetime
  S INPUT(1)="MSH^PING^"_HLDPDM_"^PING^"_HLDPNM_"^"_$$HTE^XLFDT($H)
@@ -147,11 +134,5 @@
  . ;non-standard HL7 header; start block,header,end block
  . S HLX1=$H
- . ;
- . ; HL*1.6*122 start
- . ; replace flush character '!' with @IOF (! or #)
- . ; W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
- . W $C(11)_INPUT(1)_$C(28)_$C(13),@IOF
- . ; HL*1.6*122 end
- . ;
+ . W $C(11)_INPUT(1)_$C(28)_$C(13),! ;HL*1.6*115, restored ! char
  . ;read response
  . R X:HLDREAD
@@ -179,20 +160,10 @@
  N HLDOM,HLIP S HLCS=""
  S HLDOM=$P(^HLCS(870,HLDP,0),U,7)
- ; patch HL*1.6*122 start
- S HLDOM("DNS")=$P($G(^HLCS(870,+$G(HLDP),0)),"^",8)
- ; I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
- I 'HLDOM,($L(HLDOM("DNS"),".")<3) D  Q
- . I 'HLQUIET W !,"Domain Unknown"
- . S HLCS="-1^Connection Fail"
- ; patch HL*1.6*122 end
+ I 'HLDOM,'HLQUIET W !,"Domain Unknown" Q
  I HLDOM S HLDOM=$P(^DIC(4.2,HLDOM,0),U)
- ; patch HL*1.6*122
- ; I HLDOM]"" D  Q:'POP
- I HLDOM]""!($L(HLDOM("DNS"),".")>2) D  Q:'POP
+ I HLDOM]"" D  Q:'POP
  . I HLDOM["VA.GOV"&(HLDOM'[".MED.") S HLDOM=$P(HLDOM,".VA.GOV")_".MED.VA.GOV"
  . I HLTCPORT=5000 S HLDOM="HL7."_HLDOM
  . I HLTCPORT=5500 S HLDOM="MPI."_HLDOM
- . ; patch HL*1.6*122
- . I ($L(HLDOM("DNS"),".")>2) S HLDOM=HLDOM("DNS")
  . I 'HLQUIET W !,"Domain, "_HLDOM
  . I 'HLQUIET W !,"Port: ",HLTCPORT
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;07/18/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+HLOAPI1 ;ALB/CJM-HL7 - Developer API's for sending & receiving messages(continued) ;02/06/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -54,9 +54,9 @@
  .I '$G(HLMSTATE("BODY")),'$G(HLMSTATE("UNSTORED LINES")) S ERROR="MESSAGE NOT YET CREATED" Q
  .;
- .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO^HLOAPI2(.HLMSTATE,.WHOTO,.ERR2) D
+ .I $$CHKPARMS^HLOAPI2(.HLMSTATE,.PARMS,.ERR1)&$$CHKWHO(.HLMSTATE,.WHOTO,.ERR2) D
  ..I $$SEND(.HLMSTATE,.ERROR) S SUCCESS=1
  .E  D
- ..S ERROR=$G(ERR1)_": "_$G(ERR2)
- ..D DONTSEND(.HLMSTATE,ERROR)
+ .S ERROR=$G(ERR1)_": "_$G(ERR2)
+ .D DONTSEND(.HLMSTATE,ERROR)
  K PARMS,WHOTO
  Q $S(SUCCESS:HLMSTATE("IEN"),1:0)
@@ -106,5 +106,5 @@
  .K STATE M STATE=HLMSTATE S STATE("IEN")=""
  .S ERROR=""
- .I $$CHKWHO^HLOAPI2(.STATE,.WHO,.ERROR) D
+ .I $$CHKWHO(.STATE,.WHO,.ERROR) D
  ..I $$SEND(.STATE,.ERROR) D
  ...S WHOTO(I,"QUEUED")=1
@@ -190,14 +190,10 @@
  ;
  I '$$SAVEMSG^HLOF778(.HLMSTATE) S ERROR="$$SAVE^HLOF778 FAILED!" Q 0
- I HLMSTATE("BATCH"),$L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) S ERROR="SEQUENCE QUEUES NOT SUPPORTED FOR BATCH MESSAGES" Q 0
- I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
- .S HLMSTATE("STATUS","MOVED TO OUT QUEUE")=$$SQUE^HLOQUE(HLMSTATE("STATUS","SEQUENCE QUEUE"),HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN")) D:HLMSTATE("STATUS","MOVED TO OUT QUEUE")
- ..S $P(^HLB(HLMSTATE("IEN"),5),"^",2)=1
- E  D
- .D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN"))
+ D OUTQUE^HLOQUE(HLMSTATE("STATUS","LINK NAME"),$G(HLMSTATE("STATUS","PORT")),HLMSTATE("STATUS","QUEUE"),HLMSTATE("IEN"))
  Q HLMSTATE("IEN")
  ;
 DONTSEND(HLMSTATE,ERROR) ;
- ;This procedure does NOT send a message.  Rather, it creates an entry in file 778 with the status ER.  
+ ;This procedure does NOT send a message.  Rather, it creates an entry in file 778 with the
+ ;of "SE".  
  ;Input:
  ;       HLMSTATE - pass-by-reference
@@ -207,7 +203,20 @@
  I HLMSTATE("UNSTORED LINES"),'$$SAVEMSG^HLOF777(.HLMSTATE) ; just continue
  ;
- S HLMSTATE("STATUS")="ER"
+ S HLMSTATE("STATUS")="SE"
  S HLMSTATE("STATUS","PURGE")=$$FMADD^XLFDT(HLMSTATE("DT/TM CREATED"),HLMSTATE("SYSTEM","ERROR PURGE"))
  S HLMSTATE("STATUS","ERROR TEXT")=$G(ERROR)
  I '$$SAVEMSG^HLOF778(.HLMSTATE) ;already reported an error to the app
  Q
+ ;
+CHKWHO(HLMSTATE,WHOTO,ERROR) ;
+ N RETURN,I
+ S RETURN=1
+ I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0
+ ;
+ ;move parameters into HLMSTATE
+ S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))
+ S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))
+ S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)
+ S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))
+ F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))
+ Q RETURN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/30/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134,137**;Oct 13, 1995;Build 21
+HLOAPI2 ;ALB/CJM-HL7 - Developer API's for sending application acks ;12/11/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -66,5 +66,5 @@
  .S ACK("HDR","RECEIVING APPLICATION")=$G(HLMSTATE("HDR","SENDING APPLICATION"))
  .F I=1:1:3 S ACK("HDR","RECEIVING FACILITY",I)=$G(HLMSTATE("HDR","SENDING FACILITY",I))
- .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER")
+ .S ACK("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE")
  .S ACK("ACK TO")=$G(HLMSTATE("HDR","MESSAGE CONTROL ID"))
  .S ACK("ACK TO","IEN")=HLMSTATE("IEN")
@@ -117,17 +117,9 @@
  I LEN>20 S ERROR="QUEUE PARAMETER IS MAX 20 LENGTH",PARMS("QUEUE")=$E(PARMS("QUEUE"),1,20)
  I 'LEN S PARMS("QUEUE")="DEFAULT"
- D
- .N APPIEN
- .I $G(PARMS("SENDING APPLICATION"))="" D  Q
- ..S ERROR="SENDING APPLICATION IS REQUIRED"
- ..S PARMS("SENDING APPLICATION")=""
- .E  D  Q:'APPIEN
- ..S APPIEN=$$GETIEN^HLOAPP(PARMS("SENDING APPLICATION"))
- ..I 'APPIEN S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY"
- .I $L($G(PARMS("SEQUENCE QUEUE"))) D
- ..I ($L(PARMS("SEQUENCE QUEUE"))>30) S ERROR="SEQUENCE QUEUE NAME > 30 CHARACTERS" Q
- ..I PARMS("SEQUENCE QUEUE")["^" S ERROR="SEQUENCE QUEUE NAME MAY NOT CONTAIN '^'" Q
- ..I $G(PARMS("APP ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN APPLICATION ACKNOWLEDGMENT" Q
- ..I $G(PARMS("ACCEPT ACK TYPE"))'="AL" S ERROR="SEQUENCE QUEUES REQUIRE AN ACCEPT ACKNOWLEDGMENT" Q
+ I $G(PARMS("SENDING APPLICATION"))="" D
+ .S ERROR="SENDING APPLICATION IS REQUIRED"
+ .S PARMS("SENDING APPLICATION")=""
+ E  D
+ .I '$D(^HLD(779.2,"C",PARMS("SENDING APPLICATION"))) S ERROR="SENDING APPLICATION NOT FOUND IN THE HLO APPLICATION REGISTRY"
  ;
  ;move parameters into HLMSTATE
@@ -140,8 +132,6 @@
  S @SARY@("FAILURE RESPONSE")=$G(PARMS("FAILURE RESPONSE"))
  S @SARY@("QUEUE")=PARMS("QUEUE")
- S @SARY@("SEQUENCE QUEUE")=$G(PARMS("SEQUENCE QUEUE"))
  Q:$L(ERROR) 0
  Q 1
- ;
  ;
 SETCODE(SEG,VALUE,FIELD,COMP,REP) ;
@@ -165,15 +155,2 @@
  S @VAR=9,SEG(FIELD,REP,COMP,SUB)=$G(VALUE("ORIGINAL TEXT"))
  Q
- ;
-CHKWHO(HLMSTATE,WHOTO,ERROR) ;
- N RETURN,I
- S RETURN=1
- I '$$CHECKWHO^HLOASUB1(.WHOTO,.RETURN,.ERROR) S RETURN=0
- ;
- ;move parameters into HLMSTATE
- S HLMSTATE("STATUS","LINK IEN")=$G(RETURN("LINK IEN"))
- S HLMSTATE("STATUS","LINK NAME")=$G(RETURN("LINK NAME"))
- S HLMSTATE("STATUS","PORT")=$P($G(RETURN("RECEIVING FACILITY",2)),":",2)
- S HLMSTATE("HDR","RECEIVING APPLICATION")=$G(RETURN("RECEIVING APPLICATION"))
- F I=1:1:3 S HLMSTATE("HDR","RECEIVING FACILITY",I)=$G(RETURN("RECEIVING FACILITY",I))
- Q RETURN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPI3.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,133,134,137**;Oct 13, 1995;Build 21
+HLOAPI3 ;ALB/CJM-HL7 - Developer API's for sending application acks ;03/13/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -92,5 +92,5 @@
  .I PARMS("EVENT")="",ACK("ACK TO","BODY"),$P(SUB,"^",2) S PARMS("EVENT")=$P($G(^HLA(ACK("ACK TO","BODY"),2,$P(SUB,"^",2),0)),"^",3)
  .S PARMS("ACK TO")=PARMS("MESSAGE CONTROL ID")
- .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"ER")
+ .S PARMS("ACK TO","STATUS")=$S(PARMS("ACK CODE")="AA":"SU",1:"AE")
  .Q:'$$ADDMSG^HLOAPI(.ACK,.PARMS,.ERROR)
  .S ACK("MSA")="MSA|"_PARMS("ACK CODE")_"|"_PARMS("MESSAGE CONTROL ID")_"|"_$G(PARMS("ERROR MESSAGE"))
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOAPP.m	(revision 636)
@@ -1,9 +1,13 @@
-HLOAPP ;ALB/CJM-HL7 -Application Registry ;07/09/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,137**;Oct 13, 1995;Build 21
+HLOAPP ;ALB/CJM-HL7 -Application Registry ;10/31/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132**;Oct 13, 1995;Build 6
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
 GETIEN(NAME) ;given the application name, it finds the ien.  Returns 0 on failure
  Q:'$L($G(NAME)) 0
- Q +$O(^HLD(779.2,"C",$E(NAME,1,60),0))
+ N IEN,SUB
+ S SUB=$E(NAME,1,60)
+ S IEN=0
+ F  S IEN=$O(^HLD(779.2,"B",SUB,IEN)) Q:'IEN  Q:$P($G(^HLD(779.2,IEN,0)),"^")=NAME
+ Q +IEN
  ;
 ACTION(HEADER,ACTION,QUEUE) ;Given the parsed header of a message it returns both the action that should be performed in response to the message and the incoming queue that it should be placed on.
@@ -93,24 +97,2 @@
  S:SUBIEN ACTIVE='(+$P($G(^HLD(779.2,IEN,1,SUBIEN,0)),"^",7))
  Q ACTIVE
- ;
-EXCEPT(APPNAME) ;
- ;returns the exception handler (tag^routine) that should be invoked
- ;when an applicaiton's messages are being sequenced and an app ack
- ;is not timely received
- ;
- N IEN,RTN
- S IEN=$$GETIEN($G(APPNAME))
- I IEN S RTN=$P($G(^HLD(779.2,IEN,0)),"^",10,11)
- I $L($G(RTN))>1 Q RTN
- Q "DEFAULT^HLOAPP"
- ;
-DEFAULT ;default exception handler if the app doesn't specify one
- S ^TMP("HLO SEQUENCING EXCEPTION",$J,$$NOW^XLFDT,+$G(HLMSGIEN))=""
- Q
- ;
-TIMEOUT(APPNAME) ;
- N IEN,TIME
- S IEN=$$GETIEN($G(APPNAME))
- I IEN S TIME=$P($G(^HLD(779.2,IEN,0)),"^",12)
- Q:'$G(TIME) 10
- Q TIME
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;08/15/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+HLOCLNT ;ALB/CJM- Client for sending messages - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -155,6 +155,4 @@
  .;
  .;try to send the message
- .;
- .;
  .Q:'$$WRITEMSG^HLOCLNT1(.HLCSTATE,.HLMSTATE)
  .;does the message need an accept ack?
@@ -170,20 +168,10 @@
  ..S $P(UPDATE,"^",5)=1
  ..S UPDATE("MSA")=ACKID_"^"_MSA
- ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="ER",$P(UPDATE,"^",4)=2
+ ..I '(ACKCODE="CA") S $P(UPDATE,"^",3)="SE",$P(UPDATE,"^",4)=2
  ..I ACKCODE="CA",HLMSTATE("HDR","APP ACK TYPE")="NE" S $P(UPDATE,"^",3)="SU",$P(UPDATE,"^",4)=$S(HLMSTATE("BATCH"):"2",1:1)
- ..I ($P(UPDATE,"^",3)="ER") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
+ ..I ($P(UPDATE,"^",3)="SE") S $P(UPDATE,"^",6)=$P(HLMSTATE("HDR",1),FS,5) ;errors need the application for xref
  ..;
- ..;if it's from a sequence queue, timestamp the queue
- ..I $L($G(HLMSTATE("STATUS","SEQUENCE QUEUE"))) D
- ...L +^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")):200
- ...I $P($G(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))),"^")'=MSGIEN L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
- ...I ACKCODE="CA" S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$$FMADD^XLFDT($P(UPDATE,"^",2),,,$$TIMEOUT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))) L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")) Q
- ...;if the message wasn't accepted, need to notify without waiting
- ...S $P(^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE")),"^",2)=$P(UPDATE,"^",2)
- ...L -^HLB("QUEUE","SEQUENCE",HLMSTATE("STATUS","SEQUENCE QUEUE"))
- ..;
- ..;does the app need notification of accept ack?
+ ..;did the app request notification of accept ack?
  ..S UPDATE("ACTION")=HLMSTATE("ACCEPT ACK RESPONSE")
- ..;
  ..S SUCCESS=1
  .E  D  ;accept ack wasn't requested
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004  14:43 ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+HLOCLNT1 ;IRMFO-ALB/CJM - Writing messages, reading acks;03/24/2004  14:43 ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -146,5 +146,5 @@
  ...S $P(^HLB(MSG,0),"^",21)=COUNT_" FAILED TRANSMISSIONS"
  ...S $P(^HLB(MSG,0),"^",20)="TF"
- ...S ^HLB("ERRORS",RAPP,TIME,MSG)=""
+ ...S ^HLB("ERRORS","TF",SAPP,TIME,MSG)=""
  ...D COUNT^HLOESTAT("OUT",RAPP,SAPP,MTYPE,EVENT)
  ...S ACTION=$P(NODE0,"^",14,15)
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
+HLOCLNT2 ;ALB/CJM- Performs message updates for the client - 10/4/94 1pm ;03/09/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -53,7 +53,7 @@
 UPDATE(MSGIEN,TIME,PARMS) ;
  S:PARMS("STATUS")]"" $P(^HLB(MSGIEN,0),"^",20)=PARMS("STATUS")
- I PARMS("STATUS")="ER" D
- .S ^HLB("ERRORS",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
- .D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
+ S:PARMS("STATUS")="SE" ^HLB("ERRORS","SE",PARMS("RECEIVING APP"),TIME,MSGIEN)=""
+ S:PARMS("STATUS")="AE" ^HLB("ERRORS","AE",PARMS("RECEIVING APP"),TIME,MSGIEN_"^")=""
+ I PARMS("STATUS")["E" D COUNT^HLOESTAT("OUT",PARMS("RECEIVING APP"),$$GETSAP(MSGIEN),$$GETMTYPE(MSGIEN))
  S:PARMS("ACCEPT ACK") $P(^HLB(MSGIEN,0),"^",17)=PARMS("ACCEPT ACK")
  S $P(^HLB(MSGIEN,0),"^",16)=TIME
@@ -101,5 +101,4 @@
  ;    "ID" - message id from the header
  ;    "IEN" - ien, file 778
- ;    "STATUS","SEQUENCE QUEUE")=name of the sequence queue (optional)
  ;
  K MSG
@@ -147,5 +146,4 @@
  .S MSG("HDR","ACCEPT ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"ACCEPT ACK TYPE=",2),1,2)
  .S MSG("HDR","APP ACK TYPE")=$E($P($P(MSG("HDR",2),FS,4),"APP ACK TYPE=",2),1,2)
- S MSG("STATUS","SEQUENCE QUEUE")=$P($G(^HLB(IEN,5)),"^")
  Q 1
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCLNT3.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21
+HLOCLNT3 ;ALB/CJM- Updates messages missing application acks - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -29,9 +29,9 @@
  .S $P(^HLB(MSGIEN,0),"^",9)=PURGE
  .S ^HLB("AD","OUT",PURGE,MSGIEN)=""
- .S $P(^HLB(MSGIEN,0),"^",20)="ER"
+ .S $P(^HLB(MSGIEN,0),"^",20)="AE"
  .S $P(^HLB(MSGIEN,0),"^",21)="MISSING APPLICATION ACKNOWLEDGMENT"
  .M HDR=MSG("HDR")
  .Q:'$$PARSEHDR^HLOPRS(.HDR)
- .S ^HLB("ERRORS",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""
+ .S ^HLB("ERRORS","AE",$S($L(HDR("RECEIVING APPLICATION")):HDR("RECEIVING APPLICATION"),1:"UNKNOWN"),NOW,MSGIEN)=""
  .D COUNT^HLOESTAT("OUT",HDR("RECEIVING APPLICATION"),HDR("SENDING APPLICATION"),$S(MSG("BATCH"):"BATCH",1:$G(HDR("MESSAGE TYPE"))),$G(HDR("EVENT")))
  S:MSGIEN>99999999999 MSGIEN=0
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOCNRT.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;07/24/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+HLOCNRT ;DAOU/ALA-Generate HL7 Optimized Message ;03/15/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -17,9 +17,8 @@
  ;   ARYTYP = The array where HL7 message resides
  ;   HLP = Additional HL7 message parameters (optional, pass by reference)
- ;        These optional subscripts to HLP are supported for input:
- ;             "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received
- ;             "CONTPTR"
+ ;        These optional subscripts to HLL are supported for input:
  ;             "SECURITY"
- ;             "SEQUENCE QUEUE" - queue used to maintain the order of the messages via application acks.  If used, the application MUST specify that both an accept ack and application ack be returned. 
+ ;              "CONTPTR"
+ ;              "APP ACK RESPONSE" = <tag^routine> to call when the app ack is received
  ;        
  ;   HLL  (optional, pass by reference) Additional message recipients being dynamically added
@@ -51,5 +50,4 @@
  . I $G(HLP("CONTPTR"))'="" S APPARMS("CONTINUATION POINTER")=HLP("CONTPTR")
  . I $G(HLP("QUEUE"))'="" S APPARMS("QUEUE")=HLP("QUEUE")
- . I $G(HLP("SEQUENCE QUEUE"))'="" S APPARMS("SEQUENCE QUEUE")=HLP("SEQUENCE QUEUE")
  . I $G(HLP("APP ACK RESPONSE"))'="" S APPARMS("APP ACK RESPONSE")=HLP("APP ACK RESPONSE")
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOF778 ;ALB/CJM-HL7 - Saving messages to file 778 ;03/15/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -142,9 +142,9 @@
  .S $P(^HLB(IEN,3,SUBIEN,0),"^",4)=$G(ACKTO("ACK BY"))
  .S $P(^HLB(IEN,3,SUBIEN,0),"^",5)=STATUS
- I (STATUS="ER"),'SKIP D
+ I (STATUS="AE"),'SKIP D
  .N APP
- .S APP=HLMSTATE("HDR","RECEIVING APPLICATION")
+ .S APP=HLMSTATE("HDR","SENDING APPLICATION")
  .I APP="" S APP="UNKNOWN"
- .S ^HLB("ERRORS",APP,$$NOW^XLFDT,ACKTO("IEN"))=""
+ .S ^HLB("ERRORS","AE",APP,$$NOW^XLFDT,ACKTO("IEN"))=""
  .;don't count the error - the app ack was already counted as an error.
  .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOF778A.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOF778A ;ALB/CJM-HL7 - Saving messages to file 778 (continued) ;03/07/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -47,6 +47,6 @@
  .S ^HLB("B",ID,IEN)=""
  .S ^HLB("C",HLMSTATE("BODY"),IEN)=""
- .I ($G(@STAT)="ER") D
- ..S ^HLB("ERRORS",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
+ .I ($G(@STAT)="SE") D
+ ..S ^HLB("ERRORS","SE",$S($L($G(HLMSTATE("HDR","RECEIVING APPLICATION"))):HLMSTATE("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),HLMSTATE("DT/TM CREATED"),IEN)=""
  ..D COUNT^HLOESTAT("OUT",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
  .;
@@ -70,7 +70,4 @@
  ;The "SEARCH" x-ref will be created asynchronously
  S ^HLTMP("PENDING SEARCH X-REF",$J,HLMSTATE("DT/TM CREATED"),IEN)=""
- ;
- ;sequence q?
- I HLMSTATE("DIRECTION")="OUT",$G(@STAT@("SEQUENCE QUEUE"))'="" S ^HLB(IEN,5)=@STAT@("SEQUENCE QUEUE")
  ;
  Q IEN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOFILER.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21
+HLOFILER ;ALB/CJM- Passes messages on the incoming queue to the applications - 10/4/94 1pm ;03/28/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -115,5 +115,5 @@
  D DEQUE()
  ;
- ;may need to change the status to Error
+ ;may need to change the status to Application Error
  D
  .N NODE,RAPP,SAPP,FS,CS,REP,ESCAPE,SUBCOMP,HDR,DIR,NOW
@@ -121,6 +121,6 @@
  .S NODE=$G(^HLB(MSGIEN,0))
  .Q:NODE=""
- .Q:$P(NODE,"^",20)="ER"
- .S $P(NODE,"^",20)="ER",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"
+ .Q:$P(NODE,"^",20)="AE"
+ .S $P(NODE,"^",20)="AE",$P(NODE,"^",21)="APPLICATION ROUTINE ERROR"
  .S DIR=$S($E($P(NODE,"^",4))="I":"IN",1:"OUT")
  .I $P(NODE,"^",9) K ^HLB("AD",DIR,$P(NODE,"^",9),MSGIEN)
@@ -138,5 +138,5 @@
  .I RAPP="" S RAPP="UNKNOWN"
  .S SAPP=$$DESCAPE^HLOPRS1($P($P(HDR,FS,3),CS),FS,CS,SUBCOMP,REP,ESCAPE)
- .S ^HLB("ERRORS",RAPP,NOW,MSGIEN)=""
+ .S ^HLB("ERRORS","AE",RAPP,NOW,MSGIEN)=""
  .D COUNT^HLOESTAT(DIR,RAPP,SAPP,"UNKNOWN")
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOMSG.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;07/25/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOMSG ;ALB/CJM-HL7 - APIs for files 777/778 ;02/04/2004
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -43,5 +43,4 @@
  ;     "PURGE" - scheduled purge dt/tm
  ;     "QUEUE" - the queue that the message was placed on
- ;     "SEQUENCE QUEUE" - the sequence queue (optional)
  ;
  K MSG
@@ -96,10 +95,4 @@
  .S MSG("MESSAGE TYPE")=$P(NODE,"^",3)
  .S MSG("EVENT")=$P(NODE,"^",4)
- I MSG("DIRECTION")="OUT" D
- .N NODE5
- .S NODE5=$G(^HLB(IEN,5))
- .S MSG("STATUS","SEQUENCE QUEUE")=$P(NODE5,"^")
- .S MSG("STATUS","MOVED TO OUT QUEUE")=$P(NODE5,"^",2)
- .S MSG("STATUS","SEQUENCE EXCEPTION RAISED")=$P(NODE5,"^",3)
  Q 1
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPOST.m	(revision 636)
@@ -1,5 +1,4 @@
-HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004  14:43 ;07/20/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLOPOST ;IRMFO-ALB/CJM -Post-Install routine for HLO;03/24/2004  14:43 ;05/03/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
  ;
  N SYSTEM,DATA,VASITE,OLDSITE
@@ -80,13 +79,2 @@
  S ^HLD(779.3,IEN,0)="PURGE OLD MESSAGES^1^0^2^20^^5^GETWORK^HLOPURGE^DOWORK^HLOPURGE^1^0"
  Q
- ;
-P137 ;
- ;move the existing errros to the new structure
- N TYPE
- K ^TMP($J,"HLO ERRORS")
- F TYPE="TF","SE","AE" D
- .M ^TMP($J,"HLO ERRORS",TYPE)=^HLB("ERRORS",TYPE)
- .M ^HLB("ERRORS")=^TMP($J,"HLO ERRORS",TYPE)
- .K ^TMP($J,"HLO ERRORS",TYPE)
- .K ^HLB("ERRORS",TYPE)
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOPURGE.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;07/25/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,136,137**;Oct 13, 1995;Build 21
+HLOPURGE ;IRMFO-ALB/CJM - Purging Old Messages;03/24/2004  14:43 ;04/30/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134,136**;Oct 13, 1995;Build 9
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -28,5 +28,5 @@
  Q
 OLD778 ;
- N OLD,START,END,APP,TYPE,TODAY,PARMS
+ N OLD,START,END,APP,TYPE,TODAY
  S TODAY=$$DT^XLFDT
  S OLD=$$FMADD^XLFDT(TODAY,-45)
@@ -58,11 +58,10 @@
  ;
  ;also kill old errors left lying around
- D SYSPARMS^HLOSITE(.PARMS)
- S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
- S APP=""
- F  S APP=$O(^HLB("ERRORS",APP)) Q:APP=""  D
- .N TIME
+ F TYPE="TF","AE","SE" S APP="" F  S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP=""  D
+ .N TIME,PARMS
+ .D SYSPARMS^HLOSITE(.PARMS)
+ .S OLD=$$FMADD^XLFDT($$DT^XLFDT,-PARMS("ERROR PURGE"))
  .S TIME=0
- .F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:TIME>OLD  K ^HLB("ERRORS",APP,TIME)
+ .F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:TIME>OLD  K ^HLB("ERRORS",TYPE,APP,TIME)
  Q
 OLD777 ;
@@ -102,10 +101,12 @@
  ;if an error status,take care of the "ERRORS" x-ref
  I MSG("STATUS")'="",MSG("STATUS")'="SU",MSG("BODY") D
- .K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),MSGIEN)
- .I MSG("STATUS")="ER" D
+ .N APP
+ .S APP=$S(MSG("STATUS")="TF":SAPP,1:RAPP)
+ .K ^HLB("ERRORS",MSG("STATUS"),APP,MSG("DT/TM CREATED"),MSGIEN)
+ .I MSG("STATUS")="AE" D
  ..N SUB
  ..S SUB=MSGIEN_"^"
- ..K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
- ..F  S SUB=$O(^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)) Q:SUB=""  Q:+SUB'=MSGIEN  K ^HLB("ERRORS",RAPP,MSG("DT/TM CREATED"),SUB)
+ ..K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
+ ..F  S SUB=$O(^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)) Q:SUB=""  Q:+SUB'=MSGIEN  K ^HLB("ERRORS","AE",APP,MSG("DT/TM CREATED"),SUB)
  ;
  ;kill the whole-file xrefs for the message ien within a batch
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOQUE.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;07/31/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,132,134,137**;Oct 13, 1995;Build 21
+HLOQUE ;ALB/CJM- HL7 QUEUE MANAGEMENT - 10/4/94 1pm ;01/05/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,132,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -90,131 +90,2 @@
  I $G(^HLTMP("STOPPED QUEUES",DIR,QUEUE)) Q 1
  Q 0
- ;
-SQUE(SQUE,LINKNAME,PORT,QNAME,IEN778) ;
- ;Will place the message=IEN778 on the sequencing queue. This is always done in the context of the application calling an HLO API to send a message.
- ;Input:
- ;  SQUE - name of the sequencing queue
- ;  LINKNAME = name of (.01) the logical link
- ;  PORT (optional) the port to connect to
- ;  QNAME (optional) outgoing queue
- ;  IEN778 = ien of the message in file 778
- ;Output: 1 if placed on the outgoing queue, 0 if placed on the sequence queue
- ;
- N NEXT,MOVED
- S MOVED=0
- ;
- ;keep a count of messages pending on sequence queues for the HLO System Monitor
- I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")))
- ;
- L +^HLB("QUEUE","SEQUENCE",SQUE):200
- ;
- S NEXT=+$G(^HLB("QUEUE","SEQUENCE",SQUE))
- Q:NEXT=IEN778 0  ;already queued!
- ;if the sequence queue is empty and not waiting on a message, then the message can be put directly on the outgoing queue, bypassing the sequence queue
- I '$O(^HLB("QUEUE","SEQUENCE",SQUE,0)),'NEXT D
- .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;to mean something moved to outgoing but not yet transmitted
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- .D OUTQUE(.LINKNAME,.PORT,.QNAME,IEN778)
- .S MOVED=1
- E  D
- .;Put the message on the sequence queue.
- .S ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)=""
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- Q MOVED
- ;
-ADVANCE(SQUE,MSGIEN) ;
- ;Will move the specified sequencing queue to the next message. 
- ;Input:
- ;  SQUE - name of the sequencing queue
- ;  MSGIEN - the ien of the message upon which the sequence queue was waiting.  If it is NOT the correct ien, then the sequence queue will NOT be advance.
- ;Output:
- ;  Function - 1 if advanced, 0 if not
- ;
- N NODE,IEN778,LINKNAME,PORT,QNAME
- Q:'$L($G(SQUE)) 0
- Q:'$G(MSGIEN) 0
- L +^HLB("QUEUE","SEQUENCE",SQUE):200
- ;
- ;do not advance if the queue wasn't pending the message=MSGIEN
- I (MSGIEN'=$P($G(^HLB("QUEUE","SEQUENCE",SQUE)),"^")) L -^HLB("QUEUE","SEQUENCE",SQUE) Q 0
- ;
- I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues
- ;
- S IEN778=0
- ;look for the first message on the sequence que.  Make sure its valid, if not remove the invalid entry and keep looking.
- F  S IEN778=$O(^HLB("QUEUE","SEQUENCE",SQUE,0)) Q:'IEN778  S NODE=$G(^HLB(IEN778,0)) Q:$L(NODE)  D
- .;message does not exist! Remove from queue and try again.
- .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778)
- .I $$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE")),-1)<0,$$INC^HLOSITE($NA(^HLC("QUEUECOUNT","SEQUENCE"))) ;decrement the count of messages pending sequence queues
- ;
- ;IEN778 is the next pending msg on this sequence queue
- I IEN778 D
- .;
- .;parse out info needed to move to outgoing queue
- .S LINKNAME=$P(NODE,"^",5),PORT=$P(NODE,"^",8),QNAME=$P(NODE,"^",6)
- .;
- .S ^HLB("QUEUE","SEQUENCE",SQUE)=IEN778 ;indicates this sequence queue is now waiting for msg=IEN778 before advancing.  The second pieces is the timer, but will not be set until the message=IEN778 is actually transmitted.
- .K ^HLB("QUEUE","SEQUENCE",SQUE,IEN778) ;remove from sequence queue
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- .S $P(^HLB(IEN778,5),"^",2)=1
- .D OUTQUE(.LINKNAME,$G(PORT),$G(QNAME),IEN778) ;move to outgoing queue
- E  D
- .K ^HLB("QUEUE","SEQUENCE",SQUE) ;this sequence queue is currently empty and not needed
- .L -^HLB("QUEUE","SEQUENCE",SQUE)
- Q 1
- ;
-SEQCHK(WORK) ;functions under the HLO Process Manager
- ;check sequence queues for timeout
- N QUE,NOW
- S NOW=$$NOW^XLFDT
- S QUE=""
- F  S QUE=$O(^HLB("QUEUE","SEQUENCE",QUE)) Q:QUE=""  D
- .N NODE,MSGIEN,ACTION,NODE
- .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))
- .Q:'$P(NODE,"^",2)
- .Q:$P(NODE,"^",2)>NOW
- .Q:$P(NODE,"^",3)
- .L +^HLB("QUEUE","SEQUENCE",QUE):2
- .;don't report if a lock wasn't obtained
- .Q:'$T
- .S NODE=$G(^HLB("QUEUE","SEQUENCE",QUE))
- .I '$P(NODE,"^",2) L -^HLB("QUEUE","SEQUENCE",QUE) Q
- .I ($P(NODE,"^",2)>NOW) L -^HLB("QUEUE","SEQUENCE",QUE) Q
- .I $P(NODE,"^",3) L -^HLB("QUEUE","SEQUENCE",QUE) Q  ;exception already raised
- .S MSGIEN=$P(NODE,"^")
- .I 'MSGIEN L -^HLB("QUEUE","SEQUENCE",QUE) Q
- .S ACTION=$$EXCEPT^HLOAPP($$GETSAP^HLOCLNT2(MSGIEN))
- .S $P(^HLB(MSGIEN,5),"^",3)=1
- .S $P(^HLB("QUEUE","SEQUENCE",QUE),"^",3)=1 ;indicates exception raised
- .L -^HLB("QUEUE","SEQUENCE",QUE)
- .D  ;call the application to take action
- ..N HLMSGIEN,MCODE,DUZ,QUE,NOW
- ..N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOQUE"
- ..S HLMSGIEN=MSGIEN
- ..S MCODE="D "_ACTION
- ..N MSGIEN,X
- ..D DUZ^XUP(.5)
- ..X MCODE
- ..;kill the apps variables
- ..D
- ...N ZTSK
- ...D KILL^XUSCLEAN
- Q
-ERROR ;error trap for application context
- S $ETRAP="D UNWIND^%ZTER"
- D ^%ZTER
- S $ECODE=",UAPPLICATION ERROR,"
- ;
- ;kill the apps variables
- D
- .N ZTSK,MSGIEN,QUEUE
- .D KILL^XUSCLEAN
- ;
- ;release all the locks the app may have set, except Taskman lock
- L:$D(ZTSK) ^%ZTSCH("TASK",ZTSK):1
- L:'$D(ZTSK)
- ;reset HLO's lock
- L +^HLTMP("HL7 RUNNING PROCESSES",$J):0
- ;return to processing the next message on the queue
- D UNWIND^%ZTER
- Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;07/19/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134,137**;Oct 13, 1995;Build 21
+HLOSRVR ;ALB/CJM- Server for receiving messages - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -56,5 +56,4 @@
  ..D:HLMSTATE("IEN") UPDATE(.HLMSTATE,.HLCSTATE)
  ..D:HLCSTATE("COUNTS")>4 SAVECNTS^HLOSTAT(.HLCSTATE)
- ..I $G(HLMSTATE("ACK TO","IEN")),$L($G(HLMSTATE("ACK TO","SEQUENCE QUEUE"))) D ADVANCE^HLOQUE(HLMSTATE("ACK TO","SEQUENCE QUEUE"),+HLMSTATE("ACK TO","IEN"))
  .E  D INQUE() H:HLCSTATE("CONNECTED") 1
  ;
@@ -138,5 +137,5 @@
  .I HLMSTATE("STATUS")="" S HLMSTATE("STATUS")="SU"
  .S:HLMSTATE("BATCH") WAIT=HLCSTATE("SYSTEM","ERROR PURGE")
- .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="ER"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="ER":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
+ .S:'HLMSTATE("BATCH") WAIT=$S(($G(HLMSTATE("ACK TO","STATUS"))="AE"):24*HLCSTATE("SYSTEM","ERROR PURGE"),HLMSTATE("STATUS")="SE":24*HLCSTATE("SYSTEM","ERROR PURGE"),1:HLCSTATE("SYSTEM","NORMAL PURGE"))
  .S PURGE=$$FMADD^XLFDT($$NOW^XLFDT,,WAIT)
  .S $P(^HLB(HLMSTATE("IEN"),0),"^",9)=PURGE
@@ -151,5 +150,5 @@
  I HLMSTATE("STATUS")'="" S $P(^HLB(HLMSTATE("IEN"),0),"^",20)=HLMSTATE("STATUS") S:$G(HLMSTATE("MSA",3))]"" $P(^HLB(HLMSTATE("IEN"),0),"^",21)=HLMSTATE("MSA",3) D:HLMSTATE("STATUS")="SE"
  .N APP
- .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
+ .S APP=HLMSTATE("HDR","RECEIVING APPLICATION") S:APP="" APP="UNKNOWN" S ^HLB("ERRORS","SE",APP,HLMSTATE("DT/TM"),HLMSTATE("IEN"))=""
  .D COUNT^HLOESTAT("IN",$G(HLMSTATE("HDR","RECEIVING APPLICATION")),$G(HLMSTATE("HDR","SENDING APPLICATION")),$S(HLMSTATE("BATCH"):"BATCH",1:$G(HLMSTATE("HDR","MESSAGE TYPE"))),$G(HLMSTATE("HDR","EVENT")))
  ;
@@ -161,5 +160,5 @@
  .I FROM="" S FROM="UNKNOWN SENDING FACILITY"
  .S PARMS("FROM")=FROM,PARMS("QUEUE")=HLMSTATE("STATUS","QUEUE"),PARMS("ACTION")=HLMSTATE("STATUS","ACTION")
- .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")="ER":2,$G(HLMSTATE("ACK TO","STATUS"))="ER":2,1:1)
+ .I HLMSTATE("STATUS")'="" S PARMS("PURGE")=$S(HLMSTATE("STATUS")'="SU":2,$G(HLMSTATE("ACK TO","STATUS"))="AE":2,1:1)
  .S:$G(HLMSTATE("ACK TO","IEN")) PARMS("ACKTOIEN")=HLMSTATE("ACK TO","IEN") ;to insure that the infiler will know to set the purge date at the same time as the initial message
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;07/17/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134,137**;Oct 13, 1995;Build 21
+HLOSRVR1 ;IRMFO-ALB/CJM - Reading messages, sending acks;03/24/2004  14:43 ;03/26/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,133,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -52,8 +52,6 @@
  ....S HLMSTATE("ACK TO")=OLDMSGID
  ....S HLMSTATE("ACK TO","ACK BY")=HLMSTATE("ID")
- ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"ER")
- ....I $G(IEN) D
- .....S HLMSTATE("ACK TO","IEN")=IEN
- .....S HLMSTATE("ACK TO","SEQUENCE QUEUE")=$P($G(^HLB(+IEN,5)),"^")
+ ....S HLMSTATE("ACK TO","STATUS")=$S(CODE="AA":"SU",1:"AE")
+ ....S:$D(IEN) HLMSTATE("ACK TO","IEN")=IEN
  ....S HLMSTATE("ACK TO","ERROR TEXT")=TEXT
  ...D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
@@ -68,5 +66,5 @@
  .....S HLMSTATE("BATCH","ACK TO",SUBIEN)=OLDMSGID
  .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"ACK BY")=NEWMSGID
- .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"ER")
+ .....S HLMSTATE("BATCH","ACK TO",SUBIEN,"STATUS")=$S(CODE="AA":"SU",1:"AE")
  .....S:$D(IEN) HLMSTATE("BATCH","ACK TO",SUBIEN,"IEN")=IEN
  ....D ADDSEG^HLOMSG(.HLMSTATE,.SEG)
@@ -127,5 +125,5 @@
  ;  HLMSTATE("HDR") - the parsed header segment
  ;Output:
- ;  HLMSTATE("STATUS")="ER" if an error is detected
+ ;  HLMSTATE("STATUS")="SE" if an error is detected
  ;  HLMSTATE("STATUS","QUEUE") queue to put the message on
  ;  HLMSTATE("STATUS","ACTION")  <tag^rtn> that is the processing routine for the receiving application
@@ -139,7 +137,7 @@
  E  D
  .S WANTACK=1
- I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="ER" Q
+ I HLMSTATE("ORIGINAL MODE") S HLMSTATE("MSA",1)="AE",HLMSTATE("MSA",3)="THIS INTERFACE DOES NOT IMPLEMENT ORIGINAL MODE APPLICATION ACKOWLEDGMENTS",HLMSTATE("STATUS")="SE" Q
  I $G(HLMSTATE("ACK TO"))="" D  Q:ERROR
- .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="ER" Q
+ .I '$$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S ERROR=1 S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("MSA",3)="RECEIVING APPLICATION NOT DEFINED",HLMSTATE("STATUS")="SE" Q
  .S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
  E  D  Q:ERROR  ;this is an app ack
@@ -147,6 +145,6 @@
  .N NODE
  .S:+$G(HLMSTATE("ACK TO","IEN")) NODE=$G(^HLB(+HLMSTATE("ACK TO","IEN"),0))
- .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
- .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="ER",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
+ .I $G(NODE)="" S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE TO APPLICATION ACKNOWLEDGMENT NOT FOUND" Q
+ .I $P(NODE,"^",7)'="",$P(NODE,"^",7)'=HLMSTATE("ID") S ERROR=1,HLMSTATE("STATUS")="SE",HLMSTATE("ACK TO","IEN")="" S:WANTACK HLMSTATE("MSA",1)="CE" S HLMSTATE("MSA",3)="INITIAL MESSAGE WAS ALREADY ACKED" Q
  .I ($P(NODE,"^",11)]"") S HLMSTATE("STATUS","ACTION")=$P(NODE,"^",10,11),HLMSTATE("STATUS","QUEUE")=$S($P(NODE,"^",6)]"":$P(NODE,"^",6),1:"DEFAULT")  Q
  .;processing routine for the app ack wasn't found with the original message, look in the HLO Application Registry
@@ -154,5 +152,5 @@
  .I $$ACTION^HLOAPP(.HDR,.ACTION,.QUEUE) S HLMSTATE("STATUS","ACTION")=$G(ACTION),HLMSTATE("STATUS","QUEUE")=$G(QUEUE)
  ;
- I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
+ I HDR("PROCESSING ID")'=HLCSTATE("SYSTEM","PROCESSING ID") S:WANTACK HLMSTATE("MSA",1)="CR" S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="SYSTEM PROCESSING ID="_HLCSTATE("SYSTEM","PROCESSING ID") Q
  ;
  ;wrong receiving facility?  This is hard to check if the sender is not VistA, because the HL7 standard permits different coding systems to be used. This check is only for DNS or station number.
@@ -166,5 +164,5 @@
  .I $P(HDR("RECEIVING FACILITY",2),":")[HLCSTATE("SYSTEM","DOMAIN") S PASS=1 Q
  .I HLCSTATE("SYSTEM","DOMAIN")[$P(HDR("RECEIVING FACILITY",2),":") S PASS=1 Q
- I 'PASS S HLMSTATE("STATUS")="ER",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
+ I 'PASS S HLMSTATE("STATUS")="SE",HLMSTATE("MSA",3)="RECEIVING FACILITY IS "_HLCSTATE("SYSTEM","DOMAIN") S:WANTACK HLMSTATE("MSA",1)="CE"
  I PASS,WANTACK S HLMSTATE("MSA",1)="CA"
  Q
@@ -215,7 +213,7 @@
  D END^HLOSRVR
  ;
- ;multi-listener should stop execution, only a single server may continue
+ ;concurrent server connections (multi-listener) should stop execution, only a single server may continue
  I $P($G(HLCSTATE("LINK","SERVER")),"^",2)'="S" D  Q:$QUIT "" Q
- .;don't log these errors
+ .;don't log these common errors
  .I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
  ..;
@@ -223,10 +221,11 @@
  ..D ^%ZTER
  ;
- ;debugging?
+ ;while debugging quit on all errors
  I $G(^HLTMP("LOG ALL ERRORS"))!($ECODE["EDITED") Q:$QUIT "" Q
  ;
- ;possibly an endless loop?
+ ;a lot of errors of the same time may indicate an endless loop, so keep a count and quit if large count
  N HOUR
  S HOUR=$E($$NOW^XLFDT,1,10)
+ ;
  I ($G(^TMP("HL7 ERRORS",$J,HOUR,$P($ECODE,",",2)))>30) Q:$QUIT "" Q
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOSRVR2.m	(revision 636)
@@ -1,5 +1,4 @@
-HLOSRVR2 ;ALB/CJM-HL7 - HLO Server ;07/20/2007
- ;;1.6;HEALTH LEVEL SEVEN;**131,137**;Oct 13, 1995;Build 21
- ;Per VHA Directive 2004-038, this routine should not be modified.
+HLOSRVR2 ;ALB/CJM-HL7 - Sends an application ack over an open connection, for original mode ;02/04/2004
+ ;;1.6;HEALTH LEVEL SEVEN;**131**;Oct 13, 1995;Build 10
  ;
 NEWMSG(HLCSTATE,HLMSTATE,HDR) ;
@@ -49,2 +48,46 @@
  S HLMSTATE("MSA",2)=HLMSTATE("ID")
  Q
+ ;
+ACKNOW(MSG,ERROR) ;
+ ;Sends the messge immediately if there is an open connection, otherwise
+ ;will return an error.
+ ;
+ N $ETRAP,$ESTACK S $ETRAP="G ERROR^HLOSRVR2"
+ N SENT
+ S SENT=0,ERROR=""
+ I '$G(HLCSTATE("CONNECTED")) D
+ .S ERROR="NOT CONNECTED"
+ .S MSG("STATUS")="TF"
+ E  S MSG("STATUS")="SU"
+ S:'$G(MSG("DT/TM CREATED")) MSG("DT/TM CREATED")=$$NOW^XLFDT
+ S MSG("STATUS","PURGE")=$$FMADD^XLFDT(MSG("DT/TM CREATED"),$S($G(HLCSTATE("ERROR PURGE")):HLCSTATE("ERROR PURGE"),1:7))
+ D
+ .I $G(MSG("UNSTORED LINES")),'$$SAVEMSG^HLOF777(.MSG) S ERROR="$$SAVE^HLOF777 FAILED!" Q
+ .I '$$SAVEMSG^HLOF778(.MSG) S ERROR="$$SAVE^HLOF778 FAILED!" Q
+ .Q:MSG("STATUS")'="SU"
+ .I '$$WRITEMSG^HLOCLNT1(.HLCSTATE,.MSG) S ERROR="TRANSMISSION FAILURE" Q
+ .S SENT=1
+ .D COUNT^HLOSTAT(.HLCSTATE,ACK("HDR","RECEIVING APPLICATION"),ACK("HDR","SENDING APPLICATION"),ACK("HDR","MESSAGE TYPE")_"~"_ACK("HDR","EVENT"))
+ ;
+END ;
+ I 'SENT,MSG("STATUS")="SU",$G(MSG("IEN")) D
+ .Q:'$D(^HLB(MSG("IEN"),0))
+ .S MSG("STATUS")="TF"
+ .S MSG("STATUS","ERROR TEXT")=ERROR
+ .S $P(^HLB(MSG("IEN"),0),"^",20)=MSG("STATUS")
+ .S $P(^HLB(MSG("IEN"),0),"^",21)=MSG("STATUS","ERROR TEXT")
+ .S ^HLB("ERRORS","TF",$S($L($G(MSG("HDR","RECEIVING APPLICATION"))):MSG("HDR","RECEIVING APPLICATION"),1:"UNKNOWN"),MSG("DT/TM CREATED"),IEN)=""
+ ;
+ Q SENT
+ ;
+ERROR ;error trap for ACKNOW
+ S SENT=0,ERROR="TRANSMISSION FAILURE:"_$P($ECODE,",",1,2)
+ S $ETRAP="D UNWIND^%ZTER"
+ ;
+ ;don't log some common errors
+ I ($ECODE["READ")!($ECODE["NOTOPEN")!($ECODE["DEVNOTOPN")!($ECODE["WRITE")!($ECODE["OPENERR") D
+ .;nothing!
+ E  D
+ .D ^%ZTER
+ G END^HLOSRVR2
+ Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTCP.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;07/10/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,131,134,137**;Oct 13, 1995;Build 21
+HLOTCP ;ALB/CJM- TCP/IP I/O - 10/4/94 1pm ;03/22/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,131,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -129,8 +129,8 @@
  ..S LINE=HLCSTATE("BUFFER",SEGMENT,I)
  ..F  Q:'(J+$L(LINE)>MAX)  D
- ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1
+ ...W $E(LINE,1,MAX-J),@HLCSTATE("FLUSH")
  ...S LINE=$E(LINE,(MAX-J)+1,99999)
  ...S J=0
- ..I (LINE]"") W LINE S HLCSTATE("FLUSHED")=0
+ ..W:(LINE]"") LINE
  K HLCSTATE("BUFFER")
  S HLCSTATE("BUFFER","SEGMENT COUNT")=1
@@ -203,4 +203,4 @@
  .D FLUSH
  .U HLCSTATE("DEVICE")
- .I ('$G(HLCSTATE("FLUSHED")))!$X W @HLCSTATE("FLUSH") S HLCSTATE("FLUSHED")=1
+ .W:$X @HLCSTATE("FLUSH")
  Q 0
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOTLNK.m	(revision 636)
@@ -1,4 +1,22 @@
-HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004  14:43
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,131**;Oct 13, 1995;Build 10
+HLOTLNK ;IRMFO-ALB/CJM - APIs for the HL Logical Link file;03/24/2004  14:43 ;1/23/07  16:59
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,131,135**;Oct 13, 1995;Build 10
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ;;  VWSD LOGICAL TO ALLOW A NON-VA STATION ( NODE )WITH $D(HLVWNOVA) VARIABLE EXIST FOR HL LOGICAL LINKS
  ;
 SETSHUT(LINKIEN) ;
@@ -64,10 +82,13 @@
  ;reserved for officially released links associated with VHA institutions
  ;** EXCEPTION** MPIVA is an official link associated with 200M
- ;
+ ;***LOCAL VWSD - ALLOW NON-VA STATION (NODE) AS VARIABLE HLVWNOVA TO BE USED TO DETERMINE FACILITY LINK
  Q:'$L($G(STATN)) 0
  ;
  N NAME,IEN
  S (NAME,IEN)=""
- F  S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME=""  I (NAME'="VA-VIE"),($E(NAME,1,2)="VA")!(NAME="MPIVA") S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
+ ; START LOCAL MOD VWSD FLAG HLVWNOVA
+ ; F  S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME=""  I (NAME'="VA-VIE"),($E(NAME,1,2)="VA")!(NAME="MPIVA") S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
+ F  S NAME=$O(^HLCS(870,"AC",STATN,NAME)) Q:NAME=""  I (NAME'="VA-VIE"),(($E(NAME,1,2)="VA")!(NAME="MPIVA"))!$D(HLVWNOVA) S IEN=$O(^HLCS(870,"AC",STATN,NAME,0)) Q
+ ;END LOCAL MOD
  Q IEN
  ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR.m	(revision 636)
@@ -1,25 +1,24 @@
-HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;07/30/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,130,134,137**;Oct 13, 1995;Build 21
+HLOUSR ;ALB/CJM -ListManager Screen for viewing system status;12 JUN 1997 10:00 am ;02/07/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,130,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
 EN ;
  ;
- N HLSCREEN,TESTOPEN,HLRFRSH,HLPARMS
+ N HLSCREEN,TESTOPEN,HLRFRSH
  D WAIT^DICD
  D EN^VALM("HLO SYSTEM MONITOR")
  Q
  ;
-BRIEF ;
+BRIEF ;Init variables and list array
  N COUNT,LINK,QUE,FROM,TIME,STATUS,TEMP,DIR,TODAY,LIST
  S HLRFRSH="BRIEF^HLOUSR"
  S (HLSCREEN,VALMSG)="Brief System Status"
- S VALMCNT=16
+ S VALMCNT=8
  ;K @VALMAR
  D CLEAN^VALM10
  S VALMBG=1
  S VALMBCK="R"
- S VALMDDF("COL 1")="COL1^1^80^"
  K VALMDDF("COL 2"),VALMDDF("COL 3"),VALMDDF("COL 4"),VALMDDF("COL 5")
- D CHGCAP^VALM("COL 1"," Brief Operational Overview")
+ D CHGCAP^VALM("COL 1","Brief Operational Overview")
  S @VALMAR@(1,0)="SYSTEM STATUS:             "_$S($$CHKSTOP^HLOPROC:"STOPPED",1:"RUNNING")
  S @VALMAR@(2,0)="PROCESS MANAGER:           "_$S($$RUNNING:"RUNNING",1:"STOPPED")
@@ -55,5 +54,5 @@
  ..S TEMP=$G(^HLC("QUEUECOUNT","OUT",LINK,QUE))
  ..S:TEMP>0 COUNT=COUNT+TEMP
- S @VALMAR@(8,0)="MESSAGES PENDING ON OUT QUEUES:    "_$$RJ(+COUNT,7)_"     ON SEQUENCE QUEUES:  "_$$RJ(+$G(^HLC("QUEUECOUNT","SEQUENCE")),7)
+ S @VALMAR@(8,0)="MESSAGES PENDING TRANSMISSION:      "_+COUNT
  S TEMP="STOPPED OUTGOING QUEUES: "
  S COUNT=0,QUE=""
@@ -66,5 +65,5 @@
  ..S TEMP=$G(^HLC("QUEUECOUNT","IN",QUE,FROM))
  ..S:TEMP>0 COUNT=COUNT+TEMP
- S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS: "_$$RJ(+COUNT,7)
+ S @VALMAR@(10,0)="MESSAGES PENDING ON APPLICATIONS:   "_+COUNT
  S TEMP="STOPPED INCOMING QUEUES: "
  S COUNT=0,QUE=""
@@ -93,14 +92,15 @@
  Q TOTAL
  ;
-HELP ;
+HELP ;Help code
  S X="?" D DISP^XQORM1 W !!
  Q
  ;
-EXIT ;
+EXIT ;Exit code
  D CLEAN^VALM10
  D CLEAR^VALM1
- Q
- ;
-EXPND ;
+ ;
+ Q
+ ;
+EXPND ;Expand code
  Q
  ;
@@ -111,5 +111,4 @@
  S VALMCNT=0
  S VALMBCK="R"
- S VALMDDF("COL 1")="COL1^1^34^"
  S VALMDDF("COL 2")="COL 2^35^10^MIN^H"
  S VALMDDF("COL 3")="COL 3^47^10^MAX^H"
@@ -194,5 +193,5 @@
  S VALMBCK="R"
  ;
- ;currently HL7 (Optimized) only does TCP
+ ;currently HL7 (Optimized) only does TCP, when serial added a change is needed here
  S LINK=$$ASKLINK
  Q:LINK=""
@@ -215,5 +214,5 @@
  Q $$RJ^XLFSTR($E(STRING,1,LEN),LEN)
  ;
-RUNNING() ;Process Manager running?
+RUNNING() ;Is the Process Manager running?
  N RUNNING
  L +^HLTMP("PROCESS MANAGER"):0
@@ -257,31 +256,27 @@
  Q
  ;
-UPDMODE ;realtime
+UPDMODE ;update mode
  Q:'$L(HLRFRSH)
- N TOP,BOTTOM,DX,DY,IOTM,IOBM,LINE,OLD,OLDCNT
- S OLDCNT=VALMCNT
- W !!!!!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM
- S IOTM=20,IOBM=23 W @IOSTBM
+ N QUIT,NEW,TOP,BOTTOM,DX,DY,IOTM,IOBM,I
+ W !!,IOINHI,"Hit any key to escape realtime display mode...",IOINORM
+ S IOTM=3,IOBM=23
+ W @IOSTBM
+ S DX=1,DY=$S(VALMCNT<17:VALMCNT+1,1:17) X IOXY
+ I VALMCNT>16 F I=17:1:$S(VALMCNT<22:VALMCNT,1:21) W !,@VALMAR@(I,0)
+ S QUIT=0
  S TOP=VALMBG
- S BOTTOM=TOP+20
- F LINE=TOP:1:BOTTOM D
- .I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q
- .S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80)
- F LINE=TOP:1:BOTTOM D
- .S OLD(LINE)=@VALMAR@(LINE,0)
- F LINE=17:1:BOTTOM D
- .S DX=50,DY=22 X IOXY W !
- .D WRITE^VALM10(LINE)
- D  F  R *C:4 Q:$T  D
+ S BOTTOM=TOP+23
+ S OLD=VALMAR
+ S VALMAR="NEW"
+ S VALMCNT=0
+ F  D  Q:QUIT
+ .N LINE
+ .R *C:3 I $T S QUIT=1
+ .S (VALMCNT,I)=0
  .D @HLRFRSH
- .F LINE=TOP:1:BOTTOM D
- ..I LINE>VALMCNT S @VALMAR@(LINE,0)=$$LJ(" ",80) Q
- ..S @VALMAR@(LINE,0)=$$LJ(@VALMAR@(LINE,0),80)
- .S VALMCNT=BOTTOM
- .F LINE=TOP:1:BOTTOM IF OLD(LINE)'=@VALMAR@(LINE,0) D
- ..S OLD(LINE)=@VALMAR@(LINE,0)
- ..S DX=50,DY=22 X IOXY W !
+ .F LINE=TOP:1:BOTTOM IF $G(@OLD@(LINE,0))'=$G(@VALMAR@(LINE,0)) D
+ ..S:'$D(@VALMAR@(LINE,0)) @VALMAR@(LINE,0)=" "
  ..D WRITE^VALM10(LINE)
- S VALMCNT=OLDCNT
- S VALMBCK="R"
- Q
+ K @OLD M @OLD=@VALMAR S VALMAR=OLD
+ S VALMBCK="R"
+ Q
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR1.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;07/25/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOUSR1 ;ALB/CJM -ListManager Screen for viewing messages;12 JUN 1997 10:00 am ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -101,8 +101,6 @@
  S @VALMAR@($$I,0)="Dir:   "_$$LJ($S(MSG("DIRECTION")="IN":"INCOMING",1:"OUTGOING"),10)_$$LJ("  Trans Dt/Tm: ",12)_$$FMTE^XLFDT(MSG("DT/TM"),2)_$$LJ("  Purge DT/TM: ",8)_$$FMTE^XLFDT(MSG("STATUS","PURGE"),2)
  S @VALMAR@($$I,0)="Link:  "_$$LJ(MSG("STATUS","LINK NAME"),29)_"   "_$$LJ("Queue: ",13)_MSG("STATUS","QUEUE")
- I $L($G(MSG("STATUS","SEQUENCE QUEUE"))) D
- .S @VALMAR@($$I,0)="Sequence Queue: "_MSG("STATUS","SEQUENCE QUEUE")_"    Moved: "_$S(MSG("STATUS","MOVED TO OUT QUEUE"):"YES",1:"NO")
  I MSG("STATUS","ACCEPT ACK'D") D
- .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" DT/TM Ack'd: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2)
+ .S @VALMAR@($$I,0)="Accept Ack: "_$$LJ(MSG("STATUS","ACCEPT ACK ID"),26)_$$LJ(" At: ",14)_$$FMTE^XLFDT(MSG("STATUS","ACCEPT ACK DT/TM"),2)
  .S @VALMAR@($$I,0)="   "_MSG("STATUS","ACCEPT ACK MSA")
  I MSG("DIRECTION")="IN" D
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLOUSR2.m	(revision 636)
@@ -1,4 +1,4 @@
-HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;07/17/2007
- ;;1.6;HEALTH LEVEL SEVEN;**126,134,137**;Oct 13, 1995;Build 21
+HLOUSR2 ;ALB/CJM -ListManager Screen for viewing messages(continued);12 JUN 1997 10:00 am ;03/19/2007
+ ;;1.6;HEALTH LEVEL SEVEN;**126,134**;Oct 13, 1995;Build 30
  ;Per VHA Directive 2004-038, this routine should not be modified
  ;
@@ -8,5 +8,6 @@
  Q
  ;
-SHOWLIST ;
+SHOWLIST(TYPE) ;
+ ;TYPE= "SE", "AE", "TF"
  N PARMS,I,ERRCOUNT
  S (VALMBG,VALMCNT,I,ERRCOUNT)=0
@@ -17,11 +18,11 @@
  .N APP
  .S APP=""
- .F  S APP=$O(^HLB("ERRORS",APP)) Q:APP=""  D  Q:ERRCOUNT>PARMS("MAX")
+ .F  S APP=$O(^HLB("ERRORS",TYPE,APP)) Q:APP=""  D  Q:ERRCOUNT>PARMS("MAX")
  ..N TIME,IEN
  ..S TIME=PARMS("START")
- ..Q:($O(^HLB("ERRORS",APP,TIME))="")
+ ..Q:($O(^HLB("ERRORS",TYPE,APP,TIME))="")
  ..S @VALMAR@($$I,0)="Application: "_APP
  ..D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
- ..F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN=""  D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+ ..F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN=""  D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
  E  D
  .N APP
@@ -29,40 +30,44 @@
  .N TIME,IEN
  .S TIME=PARMS("START")
- .Q:$O(^HLB("ERRORS",APP,TIME))=""
+ .Q:$O(^HLB("ERRORS",TYPE,APP,TIME))=""
  .S @VALMAR@($$I,0)="Application: "_APP
  .D CNTRL^VALM10(VALMCNT,14,$L(APP),IOINHI,IOINORM)
- .F  S TIME=$O(^HLB("ERRORS",APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",APP,TIME,IEN)) Q:IEN=""  D ADDTO(IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
+ .F  S TIME=$O(^HLB("ERRORS",TYPE,APP,TIME)) Q:'TIME  Q:ERRCOUNT>PARMS("MAX")  S IEN="" F  S IEN=$O(^HLB("ERRORS",TYPE,APP,TIME,IEN)) Q:IEN=""  D ADDTO(TYPE,IEN,TIME,.ERRCOUNT) Q:ERRCOUNT>PARMS("MAX")
  ;
 SHOW S VALMBCK="R"
  ;
  Q
-ADDTO(IEN,TIME,ERRCOUNT) ;
+ADDTO(LTYPE,IEN,TIME,ERRCOUNT) ;
  N NODE,MSG
  Q:'$$GETMSG^HLOMSG(+IEN,.MSG)
  S ERRCOUNT=ERRCOUNT+1
- ;application errors could be an error to a msg within a batch
- ;also, need to go to the ack msg to get the error text from the MSA segment
- ;
- N SUBIEN,MSA,ERRTEXT
- S (ERRTEXT,MSA)=""
- S SUBIEN=$P(IEN,"^",2)
- ;within batch?
- D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
- S ERRTEXT=MSG("STATUS","ERROR TEXT")
- I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D
- .N MSG,SEG,FS,AIEN
- .S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2)
- .Q:'$$GETMSG^HLOMSG(AIEN,.MSG)
- .I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0
- .F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q
- I ERRTEXT="",MSG("ACK BY")="" D
- .N FS
- .S FS=$E(MSG("HDR",1),4)
- .I $L(FS) S ERRTEXT=$P($G(MSG("STATUS","ACCEPT ACK MSA")),FS,4)
- S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,35)
- D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
- I $L(ERRTEXT)>35 D
- .S @VALMAR@($$I,0)=$$RJ(" ",45)_$E(ERRTEXT,36,115)
- S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+ I LTYPE'="AE" D
+ .N TYPE
+ .S TYPE=$S(MSG("BATCH"):"BATCH",1:MSG("MESSAGE TYPE")_"~"_MSG("EVENT"))
+ .S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(TYPE,8)_$$LJ($$FMTE^XLFDT(TIME,2),20)_MSG("STATUS","ERROR TEXT")
+ .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+ .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
+ E  D
+ .;application errors - could be an error to a msg within a batch
+ .;also, need to go to the ack msg to get the error text from the MSA segment
+ .;
+ .N SUBIEN,MSA,ERRTEXT
+ .S (ERRTEXT,MSA)=""
+ .S SUBIEN=$P(IEN,"^",2)
+ .;within batch?
+ .D:SUBIEN GETMSGB^HLOMSG1(.MSG,SUBIEN,.MSG)
+ .S ERRTEXT=MSG("STATUS","ERROR TEXT")
+ .I ERRTEXT="",MSG("ACK BY")]"",($$FINDMSG^HLOMSG1(MSG("ACK BY"),.LIST)=1) D
+ ..N MSG,SEG,FS,AIEN
+ ..S AIEN=+LIST(1),SUBIEN=$P(LIST(1),"^",2)
+ ..Q:'$$GETMSG^HLOMSG(AIEN,.MSG)
+ ..I SUBIEN S MSG("BATCH","CURRENT MESSAGE")=SUBIEN,MSG("LINE COUNT")=0
+ ..F  Q:'$$HLNEXT^HLOMSG(.MSG,.SEG)  I $E(SEG(1),1,3)="MSA" S MSA=SEG(1),FS=$E(MSA,4),ERRTEXT=$P(MSA,FS,4) Q
+ .S @VALMAR@($$I,0)="  "_$$LJ(MSG("ID"),15)_$$LJ(MSG("MESSAGE TYPE")_"~"_MSG("EVENT"),8)_$$LJ($$FMTE^XLFDT(MSG("DT/TM CREATED"),2),20)_$E(ERRTEXT,1,37)
+ .D CNTRL^VALM10(VALMCNT,3,15,IOINHI,IOINORM)
+ .I $L(ERRTEXT)>37 D
+ ..S @VALMAR@($$I,0)="~"_$E(ERRTEXT,38,112)
+ ..D CNTRL^VALM10(VALMCNT,1,1,IORVON,IORVOFF)
+ .S:MSG("ID")]"" @VALMAR@("INDEX",MSG("ID"))=IEN
  Q
  ;
@@ -95,6 +100,8 @@
  N DIR
  S DIR(0)="F^3:60"
- S DIR("A")="Receiving Application"
+ S DIR("A")="Application"
  S DIR("?")="Enter the full name of the application, or '^' to exit."
+ S DIR("?",1)="For transmission failures, enter the sending application. "
+ S DIR("?",2)="For other errors, enter the name of the receiving application. "
  D ^DIR
  I $D(DIRUT)!(Y="") Q ""
@@ -221,6 +228,4 @@
 LJ(STRING,LEN) ;
  Q $$LJ^XLFSTR(STRING,LEN)
-RJ(STRING,LEN) ;
- Q $$RJ^XLFSTR(STRING,LEN)
  ;
 I() ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF.m	(revision 636)
@@ -1,8 +1,4 @@
-HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;10/17/2007  09:41
- ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- Q
- ;
+HLTF ;AISC/SAW,JRP-Create/Process Message Text File Entries ;01/23/06  12:56
+ ;;1.6;HEALTH LEVEL SEVEN;**1,19,43,55,109,120**;Oct 13, 1995;Build 12
 FILE ;Create Entries in files 772 and 773 for Version 1.5 Interface Only
  D CREATE(,.HLDA,.HLDT,.HLDT1)
@@ -75,11 +71,5 @@
 MA(X,HLMID) ;X=ien in file 772, HLMID=msg. id (passed by ref.)
  ;return ien in file 773
- ;
- ; patch HL*1.6*122: MPI-client/server start
- F  L +^HL(772,+$G(X)):10 Q:$T  H 1
  Q:'$G(^HL(772,X,0)) 0
- L -^HL(772,+$G(X))
- ; patch HL*1.6*122: MPI-client/server end
- ;
  N DA,DD,DO,DIC,DIE,DR,HLDA,HLCNT,HLJ,Y
  S DIC="^HLMA(",DIC(0)="L"
@@ -118,26 +108,85 @@
 OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message
  ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ;
- D OUT^HLTF2($G(HLDA),$G(HLMID),$G(HLMTN))
+ Q:'$D(HLFS)
+ ;
+ I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"I") Q
+ ;
+ ;-- if message contained MSA find inbound message
+ I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D
+ . N HLDAI
+ . S HLDAI=0
+ . F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I")
+ . I 'HLDAI K HLDAI
+ ;
+ D STUFF^HLTF0("O")
+ ;
+ N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))
+ ;
+ ;-- update status if MSA and found inbound message
+ I $D(HLMSA),$D(HLDAI) D
+ .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+ .S HLAC=$P(HLMSA,HLFS,2)
+ .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR
+ .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
  Q
  ;
 IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message
  ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ;
- D IN^HLTF2($G(HLMTN),$G(HLMID),$G(HLTIME))
+ Q:'$D(HLFS)
+ I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"O",$G(HLDA)) Q
+ ;
+ N HLDAI S HLDA=0
+ I $D(HLNDAP),HLMID]"" D
+ .F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I")
+ .I HLDA D
+ ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)
+ ..K ^HL(772,HLDA,"IN")
+ .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D
+ ..S HLDAI=0
+ ..F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O")
+ ..I 'HLDAI K HLDAI
+ ;
+ I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
+ ;
+ D STUFF^HLTF0("I")
+ N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
+ ;
+ D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)
+ ;
+ I '$D(HLERR),$D(HLMSA),$D(HLDAI) D
+ .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
+ .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR
+ .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
  Q
  ;
 ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ;
- D ACK^HLTF2($G(HLMSA),$G(HLIO),$G(HLDA))
+ ; To determine the correct message to link the ACK, HLIO is used.
+ ; For an ack from DHCP (original message from remote system) then
+ ; HLIO should be "I" so that the correct inbound message is ack-ed. For
+ ; an inbound ack (original message outbound from DHCP) HLIO should be
+ ; "O". This distinction must be made due to the possible duplicate
+ ; message ids from a bi-direction interface.
+ ;
+ ; Input : MSA - MSA from ACK message.
+ ;         HLIO - Either "I" or "O" : See note above.
+ ;Output : None
+ ;
+ N HLAC,HLMIDI
+ ;-- set up required vars
+ S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)
+ ;-- quit
+ Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))
+ ;-- find message to ack
+ I '$G(HLDA) S HLDA=0 D
+ . F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO)
+ ;-- quit if no message
+ Q:'$D(^HL(772,+HLDA,0))
+ ;-- check for error
+ I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)
+ I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR
+ ;-- update status
+ S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
+ D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
  Q
  ;
@@ -152,16 +201,12 @@
  I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
  ;
- I OS'["DSM",OS'["OpenM" D
+ ; patch HL*1.6*120, protect Else command
+ ; I OS'["DSM",OS'["OpenM" D
+ I OS'["DSM",OS'["OpenM" D  I 1
  .F  L +^HLCS(869.3,1,772):10 S IEN=+$G(^HLCS(869.3,1,772))+1,^HLCS(869.3,1,772)=IEN S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) L -^HLCS(869.3,1,772) Q:IEN
  E  D
  .F  S IEN=$I(^HLCS(869.3,1,772),1) S:$D(^HL(772,IEN)) IEN=0,^HLCS(869.3,1,772)=($O(^HL(772,":"),-1)\1) Q:IEN
- ;
- ; patch HL*1.6*122: MPI-client/server start
- F  L +^HL(772,IEN):10 Q:$T  H 1
  S ^HL(772,IEN,0)=$G(FLD01)_"^"
  I $L($G(FLD01)) S ^HL(772,"B",FLD01,IEN)=""
- L -^HL(772,IEN)
- ; patch HL*1.6*122: MPI-client/server end
- ;
  Q IEN
  ;
@@ -176,14 +221,11 @@
  I '$L($G(OS)) N OS S OS=$G(^%ZOSF("OS"))
  ;
- I OS'["DSM",OS'["OpenM" D
+ ; patch HL*1.6*120, protect Else command
+ ; I OS'["DSM",OS'["OpenM" D
+ I OS'["DSM",OS'["OpenM" D  I 1
  .F  L +^HLCS(869.3,1,773):10 S IEN=+$G(^HLCS(869.3,1,773))+1,^HLCS(869.3,1,773)=IEN S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) L -^HLCS(869.3,1,773) Q:IEN
  E  D
  .F  S IEN=$I(^HLCS(869.3,1,773),1) S:$D(^HLMA(IEN)) IEN=0,^HLCS(869.3,1,773)=($O(^HLMA(":"),-1)\1) Q:IEN
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLMA(IEN):10 Q:$T  H 1
  S ^HLMA(IEN,0)=$G(FLD01)_"^"
  I $L($G(FLD01)) S ^HLMA("B",FLD01,IEN)=""
- L -^HLMA(IEN)
- ;
  Q IEN
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF1.m	(revision 636)
@@ -1,6 +1,4 @@
-HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007  09:43
- ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLTF1 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;09/10/98  11:21
+ ;;1.6;HEALTH LEVEL SEVEN;**5,8,22,25,19,78**;Oct 13, 1995
 MERGE15(ARAYTYPE,MTIEN,SUB1,SUB2) ;Merge Local/Global Array From Application into
  ;Message Text File
@@ -69,7 +67,4 @@
  N HLCHAR,HLEVN,HLFS,I,X,X1,X2,X3 S (HLCHAR,HLEVN,X)=0
  ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HL(772,+$G(MTIEN)):10 Q:$T  H 1
- ;
  ;Merge data from a global array with two subscript
  I ARAYTYPE="G",$G(SUB2)'="" D
@@ -105,7 +100,4 @@
  ;-- update 0 node for message text
  S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
- ;
- ; patch HL*1.6*122: MPI-client/server
- L -^HL(772,+$G(MTIEN))
  ;
  ;File message statistics
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTF2.m	(revision 636)
@@ -1,6 +1,4 @@
-HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;10/17/2007  09:44
- ;;1.6;HEALTH LEVEL SEVEN;**25,122**;Oct 13, 1995;Build 14
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+HLTF2 ;AISC/SAW/MTC-Process Message Text File Entries (Cont'd) ;02/24/97  13:56
+ ;;1.6;HEALTH LEVEL SEVEN;**25**;Oct 13, 1995
 MERGEIN(LLD0,LLD1,MTIEN,HDR,MSA) ;Merge Data From Communication Server
  ;Module Logical Link File into Message Text File
@@ -27,7 +25,4 @@
  N FLG,HLCHAR,HLEVN,HLFS,I,X,X1,HLDONE
  S (FLG,HLCHAR,HLEVN,X)=0
- ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HL(772,+$G(MTIEN)):10 Q:$T  H 1
  ;
  ;Move data from Logical Link file to Message Text file
@@ -56,8 +51,4 @@
  S ^HL(772,MTIEN,"IN",0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
  ;Update statistics in Message Text file for this entry
- ;
- ; patch HL*1.6*122: MPI-client/server
- L -^HL(772,+$G(MTIEN))
- ;
  D STATS^HLTF0(MTIEN,HLCHAR,HLEVN)
  Q
@@ -89,7 +80,4 @@
  S I=0
  ;
- ; patch HL*1.6*122: MPI-client/server
- F  L +^HLCS(870,+$G(LLD0),2,+$G(LLD1)):10 Q:$T  H 1
- ;
  ;-- move header into 870 from HDR array
  S X="" F  S X=$O(@HDR@(X)) Q:'X  D
@@ -104,105 +92,3 @@
  S ^HLCS(870,LLD0,2,LLD1,1,0)="^^"_I_"^"_I_"^"_$$DT^XLFDT_"^"
  ;
- ; patch HL*1.6*122: MPI-client/server
- L -^HLCS(870,+$G(LLD0),2,+$G(LLD1))
- ;
  Q
-OUT(HLDA,HLMID,HLMTN) ;File Data in Message Text File for Outgoing Message
- ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ; 
- Q:'$D(HLFS)
- ;
- I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"I") Q
- ;
- ;-- if message contained MSA find inbound message
- I $D(HLMSA),$D(HLNDAP),$P(HLMSA,HLFS,3)]"" D
- . N HLDAI
- . S HLDAI=0
- . F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="I")
- . I 'HLDAI K HLDAI
- ;
- D STUFF^HLTF0("O")
- ;
- N HLAC S HLAC=$S($D(HLERR):4,'$P(HLNDAP0,"^",10):1,1:2) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
- D:$D(HLCHAR) STATS^HLTF0(HLDA,HLCHAR,$G(HLEVN))
- ;
- ;-- update status if MSA and found inbound message
- I $D(HLMSA),$D(HLDAI) D
- .N HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
- .S HLAC=$P(HLMSA,HLFS,2)
- .I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",HLAC="AE":"Application Error",1:"")_" - "_HLERR
- .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
- Q
- ;
-IN(HLMTN,HLMID,HLTIME) ;File Data in Message Text File for Incoming Message
- ;Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ; 
- Q:'$D(HLFS)
- I HLMTN="ACK"!(HLMTN="MCF")!(HLMTN="ORR") Q:'$D(HLMSA)  D ACK(HLMSA,"O",$G(HLDA)) Q
- ;
- N HLDAI S HLDA=0
- I $D(HLNDAP),HLMID]"" D
- .F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMID,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)="I")
- .I HLDA D
- ..S HLDT=+$P($G(^HL(772,HLDA,0)),"^"),HLDT1=$$HLDATE^HLFNC(HLDT)
- ..K ^HL(772,HLDA,"IN")
- .I $D(HLMSA),$P(HLMSA,HLFS,3)]"" D
- ..S HLDAI=0
- ..F  S HLDAI=$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),$P(HLMSA,HLFS,3),HLDAI)) Q:'HLDAI!($P($G(^HL(772,+HLDAI,0)),U,4)="O")
- ..I 'HLDAI K HLDAI
- ;
- ; patch HL*1.6*122: MPI-client/server
- ; I 'HLDA D CREATE(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
- I 'HLDA D CREATE^HLTF(.HLMID,.HLDA,.HLDT,.HLDT1) K HLZ
- ;
- D STUFF^HLTF0("I")
- N HLAC S HLAC=$S($D(HLERR):4,1:1) D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
- ;
- D MERGE15^HLTF1("G",HLDA,"HLR",HLTIME)
- ;
- I '$D(HLERR),$D(HLMSA),$D(HLDAI) D
- .N HLAC,HLERR,HLMSG I $P(HLMSA,HLFS,4)]"" S HLERR=$P(HLMSA,HLFS,4)
- .S HLAC=$P(HLMSA,HLFS,2) I HLAC'="AA" S HLMSG=$S(HLAC="AR":"Application Reject",1:"Application Error")_" - "_HLERR
- .S HLAC=$S(HLAC'="AA":4,1:3) D STATUS^HLTF0(HLDAI,HLAC,$G(HLMSG))
- Q
- ;
-ACK(HLMSA,HLIO,HLDA) ;Process 'ACK' Message Type - Version 1.5 Interface Only
- ;
- ; patch HL*1.6*122: HLTF routine splitted, moves sub-routines,
- ; OUT, IN, and ACK to HLTF2 routine.
- ; 
- ; To determine the correct message to link the ACK, HLIO is used.
- ; For an ack from DHCP (original message from remote system) then
- ; HLIO should be "I" so that the correct inbound message is ack-ed. For
- ; an inbound ack (original message outbound from DHCP) HLIO should be
- ; "O". This distinction must be made due to the possible duplicate
- ; message ids from a bi-direction interface.
- ;
- ; Input : MSA - MSA from ACK message.
- ;         HLIO - Either "I" or "O" : See note above.
- ;Output : None
- ;
- N HLAC,HLMIDI
- ;-- set up required vars
- S HLAC=$P(HLMSA,HLFS,2),HLMIDI=$P(HLMSA,HLFS,3)
- ;-- quit
- Q:HLMIDI']""!(HLAC']"")!('$D(HLNDAP))
- ;-- find message to ack
- I '$G(HLDA) S HLDA=0 D
- . F  S HLDA=+$O(^HL(772,"AH",+$P($G(HLNDAP0),U,12),HLMIDI,HLDA)) Q:'HLDA!($P($G(^HL(772,+HLDA,0)),U,4)=HLIO)
- ;-- quit if no message
- Q:'$D(^HL(772,+HLDA,0))
- ;-- check for error
- I $P(HLMSA,HLFS,4)]"" N HLERR S HLERR=$P(HLMSA,HLFS,4)
- I $D(HLERR),'$D(HLMSG) N HLMSG S HLMSG="Error During Receipt of Acknowledgement Message"_$S(HLAC="AR":" - Application Reject",HLAC="AE":" - Application Error",1:"")_" - "_HLERR
- ;-- update status
- S HLAC=$S(HLMTN="MCF":2,HLAC'="AA":4,1:3)
- D STATUS^HLTF0(HLDA,HLAC,$G(HLMSG))
- Q
- ;
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTP3.m	(revision 636)
@@ -1,9 +1,9 @@
-HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;10/05/2007  15:17
- ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133,122**;Oct 13, 1995;Build 14
+HLTP3 ;SFIRMFO/RSD - Transaction Processor for TCP ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**19,43,57,58,59,66,69,109,115,108,116,117,125,120,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
  Q
-NEW(X) ;process new msg. ien in 773^ien in 772
- ;HLMTIENS=ien in #773; HLMTIEN=ien in #772
+NEW(X) ;process new msg. ien in 773^msg. ien in 772
+ ;HLMTIENS=ien in #773, msg header; HLMTIEN=ien in #772, msg text
  ;HLHDRO=original header;  HLHDR=response header
  ;set error trap
@@ -21,13 +21,14 @@
  . ;HLTCP=ien of acknowledgment msg. from ACK^HLTP4
  . D ACK^HLTP4(X,$P(HLRESLT,U,2)) Q:'$G(HLTCP)
- . ;write ack back
+ . ;write ack back over connection
  . S X=$$WRITE^HLCSTCP2(HLTCP)
  . ;update counter to sent
  . D LLCNT^HLCSTCP(HLDP,4)
- . ;update status of ack
+ . ;update status of ack to complete
  . D STATUS^HLTF0(HLTCP,3,,,1)
  ;
  ;check for duplicate msg., use rec. app and msg. id x-ref
  ; patch HL*1.6*120
+ ; I $L($G(HL("MID"))),$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
  I $G(HL("MID"))]"",$G(HL("RAP")) S X=$O(^HLMA("AH",HL("RAP"),HL("MID"),0)) D  Q:'$D(HLMTIENS)
  . ;HLASTMSG=last ien received during this connection
@@ -41,14 +42,14 @@
  .I MSH(HLMTIENS)'=MSH(OIENS) S HLASTMSG=HLMTIENS Q
  .;
- . ;msg is duplicate, set status
+ . ;msg is duplicate, set status as duplicate
  . D STATUS^HLTF0(HLMTIENS,4,109,"Duplicate with ien "_OIENS,1),EXIT
- . ;msg was resent, ignore it.
+ . ;msg was resent during this connection, ignore it.
  . I HLASTMSG=HLMTIENS K HLMTIENS Q
  . ;find original response and send back
  . S HLASTRSP=$O(^HLMA("AF",OIENS,OIENS))
  ;
- ;Quit if this is ack to ack
+ ;Quit if this is acknowledgment to acknowledgement message
  I $G(HL("ACK")) D  Q
- . ;Update status of original ack message
+ . ;Update status of original acknowledgment message to successfully
  . D STATUS^HLTF0(HL("MTIENS"),3,,,1),STATUS^HLTF0(HLMTIENS,3,,,1)
  . ;unlock record
@@ -76,5 +77,6 @@
  ; patch HL*1.6*120 start
  ;resending old response, msg is a resend
- ; do not re-send duplicate when $G(HL("ACAT"))="AL"
+ ; I $G(HLASTRSP) S HLTCP=HLASTRSP G ACK
+ ; do not re-send duplicate message when $G(HL("ACAT"))="AL"
  I $G(HLASTRSP),$G(HL("ACAT"))'="AL" S HLTCP=HLASTRSP G ACK
  ; quit if duplicate
@@ -90,9 +92,9 @@
  . ;X=1 if ack ok, 0=reject of error
  . S X=$E(HLMSA,2)="A"
- . ;Update status of original message and remove it from the queue
+ . ;Update status of original subscriber message and remove it from the out-going queue
  . D STATUS^HLTF0(HL("MTIENS"),$S(X:3,1:4),"",$S(X:"",1:$P(HLMSA,HL("FS"),3)),1)
  . D DEQUE^HLCSREP($P($G(^HLMA(HL("MTIENS"),0)),"^",7),"O",HL("MTIENS"))
  . D
- .. N HLTCP ;variable to update status in file #772.
+ .. N HLTCP ;New variable to update status in file #772.
  ..;
  ..;**108**
@@ -104,5 +106,5 @@
  ..;
  .. D PROCACK^HLTP2(HLMTIEN,HL("EID"),.HLRESLT,.HL)
- . ;update status of incoming & unlock
+ . ;update status of incoming to complete & unlock
  . D STATUS^HLTF0(HLMTIENS,$S($G(HLRESLT):4,1:3),$S($G(HLRESLT):+$G(HLRESLT),1:""),$S($G(HLRESLT):$P(HLRESLT,U,2),1:""),1),EXIT
  ;
@@ -123,5 +125,5 @@
  ;update status of incoming to complete & unlock
  D STATUS^HLTF0(HLMTIENS,$S(HLRESLT:4,1:3),$S(HLRESLT:+HLRESLT,1:""),$S(HLRESLT:$P(HLRESLT,U,2),1:""),1,$S($G(HLERR("SKIP_EVENT"))=1:1,1:0)),EXIT
- ;HLTCPO=link open, HLTCP=ien of ack msg. from GENACK
+ ;HLTCPO=link open, HLTCP=ien of acknowledgment msg. from GENACK
 ACK I $G(HLTCPO),$G(HLTCP) D  Q
  . D LLCNT^HLCSTCP(HLDP,3)
@@ -137,5 +139,5 @@
  ;
  ; patch HL*1.6*120 start
- ; clean non-Kernel variables
+ ; clean variables except Kernel related variables
  D
  . ; protect variables defined in STARTIN^HLCSIN
@@ -152,7 +154,10 @@
  N HLERR     ;patch HL*1.6*109
  Q:'$G(HLDP)!'$G(X)  Q:'$G(^HLMA(X,0))
+ ;**109 START**
  Q:'$D(^HLMA("AC","I",HLDP,X))
+ ;**109 END**
  ;
  N HL,HLA,HLD0,HLEID,HLEIDS,HLHDR,HLHDRO,HLMTIEN,HLMTIENS,HLJ,HLMSA,HLN,HLQUIT,HLNODE,HLNEXT,HLRESLT,HLRESLTA,HLTCP,HLXX,Z,HLDONE1
+ ;setup variables
  S HLMTIENS=X,X=^HLMA(HLMTIENS,0),HLMTIEN=+$P(X,U),HL("MID")=$P(X,U,2),HL("MTIENS")=$P(X,U,10),HL("LL")=$P(X,U,7),HLTCP="",HL("Q")=""""""
  S HL("EIDS")=$P(X,U,8),HL("SAP")=$P(X,U,11),HL("RAP")=$P(X,U,12),HL("MTP")=$P(X,U,13),HL("ETP")=$P(X,U,14)
@@ -164,12 +169,16 @@
  M HLHDRO=^HLMA(HLMTIENS,"MSH")
  ; if no header quit
+ ;**109**
+ ;I '$O(HLHDRO(0)) L -^HLMA(HLMTIENS) Q
  Q:'$O(HLHDRO(0))
  ;
  S HL("FS")=$E(HLHDRO(1,0),4),HL("ECH")=$$P^HLTPCK2(.HLHDRO,2),HL("SFN")=$$P^HLTPCK2(.HLHDRO,4),HL("RFN")=$$P^HLTPCK2(.HLHDRO,6),HL("DTM")=$$P^HLTPCK2(.HLHDRO,7)
  ;
+ ; patch HL*1.6*109 start
  ; quit if ien of #772 is not defined
  Q:'HLMTIEN
  ; quit if field separator is not defined
  Q:HL("FS")=""
+ ; patch HL*1.6*109 end
  ;
  S X=$$P^HLTPCK2(.HLHDRO,1)
@@ -187,5 +196,5 @@
  . S X=$$P^HLTPCK2(.HLHDRO,9),Z=$E(HL("ECH")),HL("PID")=$P(X,Z,2),HL("VER")=$P(X,Z,4)
  . ;
- . ; original code incorrectly treats repetition separator as
+ . ; original implementation incorrectly treats repetition separator as
  . ; subcomponent separator
  . I $E(HL("ECH"),2)]"",X[$E(HL("ECH"),2) D
@@ -206,9 +215,12 @@
  . S HLMSA=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),1),$P(HLMSA,HL("FS"),2)=$$P^HLTPCK2(.HLHDRO,12),$P(HLMSA,HL("FS"),3)=$P($$P^HLTPCK2(.HLHDRO,10),$E(HL("ECH")),2),HL("MSAID")=$P(HLMSA,HL("FS"),2)
  ;
+ ; HL*1.6*108
  ; quit if this is a commit ack
  I $P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),1)="MSA",$E($P($G(^HL(772,HLMTIEN,"IN",1,0)),HL("FS"),2))="C" Q
+ ; ** 
  ;
  ;**  HL*1.6*117 **
  K HLL("SET FOR APP ACK"),HLL("LINKS")
+ ;** END HL*1.6*117 **
  ;
  D CONT
@@ -217,19 +229,6 @@
 MSA(Y) ;Y=ien in 772, returns MSA segment
  ;ack code^msg being ack id^text
- ; patch HL*1.6*122
- ; for HL7 v2.5 and beyond with MSA as 3rd segment
- N X,SUBIEN,DATA,DONE
+ N X
  S X=$G(^HL(772,Y,"IN",1,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
- Q:X]"" X
- ;
- S DONE=0
- S SUBIEN=1
- F  S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN  D  Q:DONE
- . S DATA=$G(^HL(772,Y,"IN",SUBIEN,0)) I DATA="" D
- .. S DONE=1
- .. S SUBIEN=$O(^HL(772,Y,"IN",SUBIEN)) Q:'SUBIEN
- .. S X=$G(^HL(772,Y,"IN",SUBIEN,0)),X=$S($E(X,1,3)="MSA":$E(X,5,999),1:"")
- ; patch HL*1.6*122 end
- ;
  Q X
  ;
@@ -237,5 +236,5 @@
  D ^%ZTER
  I $G(HLMTIENS),$D(^HLMA(HLMTIENS,0)) D STATUS^HLTF0(HLMTIENS,4,,,1),EXIT
- ; release locks created by inbound filer
+ ;*109* release all locks created by inbound filer
  L -^HLMA("AC","I",+$G(HLXX))
  G UNWIND^%ZTER
Index: FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_LEVEL_SEVEN-HL/HLTPCK2B.m	(revision 636)
@@ -1,4 +1,4 @@
-HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;10/04/2007  16:00
- ;;1.6;HEALTH LEVEL SEVEN;**120,133,122**;Oct 13, 1995;Build 14
+HLTPCK2B ;OIFO-O/RJH - Message Header Validation (Con't) ;09/13/2006
+ ;;1.6;HEALTH LEVEL SEVEN;**120,133**;Oct 13, 1995;Build 13
  ;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -23,14 +23,9 @@
  . S X=$G(^HLMA(ARY("MTIENS"),0)),ARY("EIDS")=$P(X,U,8),ARY("ACK")=$P(X,U,10)
  . ;if no subscriber protocol then response msg. is invalid
- . ;
- . ; patch HL*1.6*122 start
- . ; comment out the following code: for patch 109- dynamic addressing
- . ; I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
+ . I ('ARY("EIDS")) S:(ERR="") ERR="Invalid Message Control ID in MSA Segment - No Subscr. IEN in 773" Q
  . ;get message text ien in file 772 and server protocol, 'EID'
  . S ARY("MTIEN")=+X,X=$G(^HL(772,+X,0)),ARY("EID")=$P(X,U,10)
  . I ('ARY("EID")) S:(ERR="") ERR="Event Protocol not found" Q
- . ; D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
- . I ARY("EIDS") D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
- . ; patch HL*1.6*122 end
+ . D EVENT^HLUTIL1(ARY("EIDS"),"770,773",.HLN)
  ;
  ;Find Server Protocol - based on sending application, message type,
Index: FOIAVistA/tag/r/HEALTH_SUMMARY-GMTS/GMTSUP.m
===================================================================
--- FOIAVistA/trunk/r/HEALTH_SUMMARY-GMTS/GMTSUP.m	(revision 631)
+++ FOIAVistA/tag/r/HEALTH_SUMMARY-GMTS/GMTSUP.m	(revision 636)
@@ -1,4 +1,4 @@
 GMTSUP ; SLC/KER - Utilities for Paging HS           ; 01/06/2003
- ;;2.7;Health Summary;**2,7,21,27,28,30,35,47,56,58,85**;Oct 20, 1995;Build 24
+ ;;2.7;Health Summary;**2,7,21,27,28,30,35,47,56,58**;Oct 20, 1995
  ;
  ; External References
@@ -118,5 +118,4 @@
  ;     Name, SSAN, Ward, DOB
  I '$D(GMTSLFG) D
- .I $G(GMTSTITL)'["AD HOC",($G(GMTSTITL)'["PDX"),($G(HSTAG)="") D EN^GMTSHCPR  ;GMTS,85 restrict ssn/dob on HS Type hard copies 
  . I $G(GMTSPHDR("TWO")) D
  . . I $D(GMTSOBJ),'$D(GMTSOBJ("REPORT HEADER")),$L($G(GMTSOBJ("LABEL"))) D LABEL
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE ; GENERATED FROM 'DVBHINQ UPDATE' INPUT TEMPLATE(#960), FILE 2;06/27/07
+DVBHCE ; GENERATED FROM 'DVBHINQ UPDATE' INPUT TEMPLATE(#960), FILE 2;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -109,5 +109,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C19F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=640 S DIEZRXR(2,DIXR)=""
+ F DIXR=648 S DIEZRXR(2,DIXR)=""
  Q
 X19 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SV^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=1 D POS^DGINP
@@ -128,5 +128,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C20F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=303,640 S DIEZRXR(2,DIXR)=""
+ F DIXR=303,648 S DIEZRXR(2,DIXR)=""
  Q
 X20 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SV^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSL") X I $D(X),$D(^DG(43,1)) S SD1=1 D PS^DGINP
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE1.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE1 ; ;06/27/07
+DVBHCE1 ; ;12/27/07
  S X=DE(24),DIC=DIE
  D EVENT^IVMPLOG(DA)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE10.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE10 ; ;06/27/07
+DVBHCE10 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE11.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE11 ; ;06/27/07
+DVBHCE11 ; ;12/27/07
  S X=DE(16),DIC=DIE
  ;
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE12.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE12 ; ;06/27/07
+DVBHCE12 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE13.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE13 ; ;06/27/07
+DVBHCE13 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE14.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE14 ; ;06/27/07
+DVBHCE14 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE15.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE15 ; ;06/27/07
+DVBHCE15 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE16.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE16 ; ;06/27/07
+DVBHCE16 ; ;12/27/07
  S X=DE(4),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE17.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE17 ; ;06/27/07
+DVBHCE17 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE18.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE18 ; ;06/27/07
+DVBHCE18 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE19.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE19 ; ;06/27/07
+DVBHCE19 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE2.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE2 ; ;06/27/07
+DVBHCE2 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE20.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE20 ; ;06/27/07
+DVBHCE20 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -143,5 +143,5 @@
  S X=$G(X(1))
  Q
-C20F2 S DIXR=703 D C20X2(U) K X2 M X2=X D C20X2("O") K X1 M X1=X
+C20F2 S DIXR=685 D C20X2(U) K X2 M X2=X D C20X2("O") K X1 M X1=X
  D
  . D FC^DGFCPROT(.DA,2,.351,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE21.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE21 ; ;06/27/07
+DVBHCE21 ; ;12/27/07
  S X=DE(20),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,2.1) X ^DD(2,.351,1,1,2.4)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE22.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE22 ; ;06/27/07
+DVBHCE22 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,0)):^(0),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y X ^DD(2,.351,1,1,1.1) X ^DD(2,.351,1,1,1.4)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE23.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE23 ; ;06/27/07
+DVBHCE23 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -128,5 +128,5 @@
  S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
-C12F1 N X,X1,X2 S DIXR=627 D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X
+C12F1 N X,X1,X2 S DIXR=646 D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X
  D
  . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE24.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE24 ; ;06/27/07
+DVBHCE24 ; ;12/27/07
  S X=DE(19),DIC=DIE
  D KILL^DGREGDD(DA)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE25.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE25 ; ;06/27/07
+DVBHCE25 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  D SET^DGREGDD(DA,X)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE26.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE26 ; ;06/27/07
+DVBHCE26 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE27.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE27 ; ;06/27/07
+DVBHCE27 ; ;12/27/07
  S X=DE(26),DIC=DIE
  ;
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE28.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE28 ; ;06/27/07
+DVBHCE28 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE29.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE29 ; ;06/27/07
+DVBHCE29 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE3.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE3 ; ;06/27/07
+DVBHCE3 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -89,5 +89,5 @@
  D EVENT^IVMPLOG(DA)
 C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=641 S DIEZRXR(2,DIXR)=""
+ F DIXR=649 S DIEZRXR(2,DIXR)=""
  Q
 X3 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER1^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSNTL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=2 D POS^DGINP
@@ -104,5 +104,5 @@
  D EVENT^IVMPLOG(DA)
 C4F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=641 S DIEZRXR(2,DIXR)=""
+ F DIXR=649 S DIEZRXR(2,DIXR)=""
  Q
 X4 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER1^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSNTL") X I $D(X),$D(^DG(43,1)) S SD1=2 D PS^DGINP
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE30.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE30.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE30.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE30 ; ;06/27/07
+DVBHCE30 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE31.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE31.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE31.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE31 ; ;06/27/07
+DVBHCE31 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE32.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE32.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE32.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE32 ; ;06/27/07
+DVBHCE32 ; ;12/27/07
  ;;
 1 N X,X1,X2 S DIXR=303 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
@@ -20,5 +20,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=640 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=648 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"LAST")
@@ -31,5 +31,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=641 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=649 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NTL")
@@ -42,5 +42,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=642 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=663 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NNTL")
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE33.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE33.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE33.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE33 ; ;09/23/06
+DVBHCE33 ; ;10/08/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE34.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE34.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE34.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE34 ; ;09/23/06
+DVBHCE34 ; ;10/08/06
  ;;
 1 N X,X1,X2 S DIXR=303 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
@@ -20,5 +20,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=640 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=648 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"LAST")
@@ -31,5 +31,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=641 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=649 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NTL")
@@ -42,5 +42,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=642 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=663 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NNTL")
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE35.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE35.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE35.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE35 ; ;04/10/06
+DVBHCE35 ; ;04/21/06
  ;;
 1 N X,X1,X2 S DIXR=303 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
@@ -20,5 +20,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=640 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=648 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"LAST")
@@ -31,5 +31,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=641 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=649 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NTL")
@@ -42,5 +42,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=642 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=663 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NNTL")
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE36.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE36.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE36.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE36 ; ;04/10/06
+DVBHCE36 ; ;04/21/06
  ;;
 1 N X,X1,X2 S DIXR=303 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
@@ -20,5 +20,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=640 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=648 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"LAST")
@@ -31,5 +31,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=641 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=649 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  D
  . D KSERV^DGSRVICE(.X,.DA,"NTL")
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE4.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE4 ; ;06/27/07
+DVBHCE4 ; ;12/27/07
  S X=DE(13),DIC=DIE
  ;
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE5.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE5 ; ;06/27/07
+DVBHCE5 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X "I X'=""Y"" S DGXRF=.32945 D ^DGDDC Q"
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE6.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE6 ; ;06/27/07
+DVBHCE6 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -60,5 +60,5 @@
  D EVENT^IVMPLOG(DA)
 C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=642 S DIEZRXR(2,DIXR)=""
+ F DIXR=663 S DIEZRXR(2,DIXR)=""
  Q
 X1 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER2^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,0,"MSNNTL") X I $D(X) S DGFRDT=X I $D(^DG(43,1)) S SD1=3 D POS^DGINP
@@ -75,5 +75,5 @@
  D EVENT^IVMPLOG(DA)
 C2F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=642 S DIEZRXR(2,DIXR)=""
+ F DIXR=663 S DIEZRXR(2,DIXR)=""
  Q
 X2 S %DT="E",%DT(0)=-DT D ^%DT K %DT S X=Y K:Y<1 X I $D(X) S DFN=DA D SER2^DGLOCK I $D(X) K:'$$VALMSE^DGRPMS(DFN,X,1,"MSNNTL") X I $D(X),$D(^DG(43,1)) S SD1=3 D PS^DGINP
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE7.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE7 ; ;06/27/07
+DVBHCE7 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -149,5 +149,5 @@
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
  I $D(DE(11))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C11F1 N X,X1,X2 S DIXR=643 D C11X1(U) K X2 M X2=X D C11X1("O") K X1 M X1=X
+C11F1 N X,X1,X2 S DIXR=664 D C11X1(U) K X2 M X2=X D C11X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^DPT("APTYPE",X,DA)
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE8.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE8 ; ;06/27/07
+DVBHCE8 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCE9.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCE9 ; ;06/27/07
+DVBHCE9 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S DFN=DA D EN^DGMTCOR K DGMTCOR
Index: FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m
===================================================================
--- FOIAVistA/trunk/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m	(revision 631)
+++ FOIAVistA/tag/r/HINQ-DVB--DVBA--DVBE--DVBC/DVBHCG.m	(revision 636)
@@ -1,3 +1,3 @@
-DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLATE (#513) ; 01/12/06 ; (FILE 2, MARGIN=80)
+DVBHCG ; GENERATED FROM 'DVBHINQ PAT-HINQ COMP' PRINT TEMPLATE (#513) ; 04/03/06 ; (FILE 2, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFACPS.m	(revision 636)
@@ -1,8 +1,8 @@
 PRCFACPS ;WISC@ALTOONA/CTB/DL-PURGE CODE SHEET CONTINUATION ;1/29/98 1300
-V ;;5.1;IFCAP;**114**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
 DQ ;;PURGE CODE SHEETS AND TRANSMISSION RECORDS
  D:$D(ZTQUEUED) KILL^%ZTLOAD
- S PRCFNAME=$S(PRCFASYS["CLMCLIRRLOG":"FEE/FEN, Receiving Reports & LOG",PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG")
+ S PRCFNAME=$S(PRCFASYS["CLM":"FEE/FEN",PRCFASYS["ISM":"ISM",PRCFASYS["IRS":"IRS",1:"LOG")
  L +^PRCF(423,0):5 I '$T S X="Code Sheet file unavailable - File lock timeout.*" D MSG^PRCFQ Q
  W:$D(IOF) @IOF W PRCFNAME_" CODE SHEET & TRANSMISSION RECORD DELETION TRANSCRIPT" D NOW^PRCFQ W ?IOM-$L(%X),%X
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFALOG.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCFALOG ;WISC/CTB-LOG CODE SHEETS ;11-27-92/08:20
-V ;;5.1;IFCAP;**114**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
 A S PRCHLOG="",PRCFASYS="LOGDLA" Q
 B K PRCHLOG,PRCFASYS Q
@@ -24,9 +24,4 @@
 PURGE ;PURGE CODE SHEETS
  D A S PRCFASYS=PRCFASYS_"PHA" D EN^PRCFACPR,B Q
-PURGE2 ;PURGE ALL CODE SHEETS
- W !!,"** YOU MUST SELECT A DESIGNATED PRINTER FOR PURGE TO FUNCTION PROPERLY."
- W !,"** DEFAULTING TO HOME DEVICE (0) WILL NOT PURGE DATA SINCE THE OPTION WILL BE "
- W !,"** TASKED.",!
- S PRCFASYS="CLMCLIRRLOGDLAPHAGSA" D EN^PRCFACPR,B Q
 ADD ;ADD CODE SHEET TO PRINTED BATCH
  D A,ADD^PRCFACR2,B Q
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEF.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCHEF ;ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;6/10/97 9:34
-V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 EN80 ;DELETE A RECEIVING REPORT (CONT.FROM PRCHE)
@@ -7,5 +7,5 @@
  I $P($G(^PRC(442,PRCHPO,23)),U,11)="S"!($P($G(^(23)),U,11)="P") W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for purchase card orders.",! G EN80
  I $P($G(^PRC(442,PRCHPO,23)),U,11)="D" W !!,?5,"Please create an adjustment voucher to delete",!,?5,"receiving reports for delivery orders.",! G EN80
- I X<25!(X>33) W $C(7)," Receiving Report cannot be deleted, please create an adjustment voucher." G EN80
+ I X<25!(X>33) W $C(7)," ??" G EN80
  I '$O(^PRC(442,PRCHPO,11,0)) W !?3,"Order has no Receiving Reports !",$C(7) G EN80
  D LCK1^PRCHE G:'$D(DA) EN80 S:$P(^PRC(442,PRCHPO,0),U,2)=8 PRCHNRQ=1
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA.m	(revision 636)
@@ -1,18 +1,31 @@
 PRCHMA ;WISC/AKS-Amend to PO, req ;6/10/96  14:07
- ;;5.1;IFCAP;**21,79,100,113**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
-REQ N PRCHREQ
+ ;;5.1;IFCAP;**21,79,100**;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
+REQ ;Req.
+ N PRCHREQ
  S PRCHREQ=1
-PO N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON,A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
- N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND,PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
+PO ;PO
+ N PRCF,RETURN,PRCHAM,PRCHPO,PRCHNEW,OUT,CAN,PRCHAU,PRCHER,PRCHON
+ N A,B,ER,FL,FIS,DELIVER,PRCHAMDA,PRCHAV,PRCHL1,PRCHLN,PRCHRET,LCNT
+ N PRCHL2,ROU,DIC,I,PRCHAMT,PRCHAREC,PRCHEDI,X,Y,PRCHN,PRCHO,SFUND
+ N PRCHX,PRCHIMP,PRCHNRQ,PRCHP,REPO,PRCHNORE,%,%A,%B,D0,D1,J
  N PRCFL,MSG
 LOOP D KILL^PRCHMA1 S PRCHNEW="",PRCHNORE=1,CAN=0
- ; See routine PRCHAMXA for information on variable PRCHNORE and undefined DIK, var PRCHPO is the basic premise of locks applied to amendments
+ ;
+ ; See routine PRCHAMXA for information on variable PRCHNORE and for
+ ; incidence of undefined DIK variable errors.
+ ; The var PRCHPO is the basic premise of locks applied to amendments.
+ ; Anytime amend module is accessed add +lock & save po# in PRCENTRY.
+ ;
  S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
- ; Lock simultaneous entry of users in amend. module for the same record.  Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start
+ ;
+ ; Lock simultaneous entry of users in amend. module for the same record.
+ ; Var Y is saved in PRCHPO at the end of GETPO subrtn, when we start
  ; the process(AMENDNO) of amending the record we must have var PRCHPO.
+ ;
  S PRCFL=0
  W !! D GETPO^PRCHAMU
- ; If no record is selected or time-out or up-arrow out then exit without unlocking a record.
+ ; If no record is selected or time-out or up-arrow out then exit
+ ; without unlocking a record.
  I $D(DTOUT)!$D(DUOUT)!$G(OUT)=1 G EXIT1
  I PRCFL=1 G LOOP
@@ -33,21 +46,10 @@
  . I $G(PRCHAMDA)=31 D MSG^PRCHAMU Q
  . I $G(PRCHAMDA)=24,$G(X)=2 D MSG1^PRCHAMU S SCE=1 Q
+ ;
  I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) S CAN=1
  I $D(DTOUT)!($D(DUOUT)) G EXIT
  I $G(NOCAN)=1 G ASK
  G:$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)'>1 EXIT
-CAN1 S BFLAG=0
- S:$P($G(^PRC(443.6,PRCHPO,1)),U,7)'=6 BFLAG=1
- I $P($G(^PRC(443.6,PRCHPO,1)),U,7)=6  D
- .S THISHLD=0
- .F  S THISHLD=$O(^PRC(443.6,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1)  D
- ..S:$P($G(^PRC(443.6,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
- .Q:BFLAG=1
- .S THISHLD=0
- .F  S THISHLD=$O(^PRC(442,PRCHPO,2,THISHLD)) Q:'THISHLD!(BFLAG=1)  D
- ..S:$P($G(^PRC(442,PRCHPO,2,THISHLD,2)),U,2)'="" BFLAG=1
- W:BFLAG=0 !,"This is now a contract order.  You must add a contract to this orders item(s)",!,"before approving the amendment.",!
- G:BFLAG=0 EXIT
- D:BFLAG=1 UPDATE^PRCHAMU G:$D(Y) EXIT
+CAN1 D UPDATE^PRCHAMU G:$D(Y) EXIT
 CHK I '$$VERIFY^PRCHES5(PRCHPO) W !!,?5,"This purchase order has been tampered with.",!,?5,"Please notify IFCAP APPLICATION COORDINATOR." G EXIT
  I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,4)']"" W !!,?5,"There is no Amendment Status." D
@@ -66,5 +68,6 @@
  ...S J=0 S J=$O(^PRC(443.6,PRCHPO,2,PRCH,1,J)) I J'>0 D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing its description!",$C(7) S PRCHER="",LCNT=LCNT+2
  ...I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)="" D:LCNT>END TOP W !!,?5,"Line item ",+$P(PRCHLN,U)," is missing contract number.",$C(7) S PRCHER="",LCNT=LCNT+2
- ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to make sure that a contract number is entered
+ ...; PRC*5.1*79 - Check line items of PC orders with source code=6 to
+ ...; make sure that a contract number is entered
  ...D PCD^PRCHMA1
  ...Q
@@ -72,8 +75,13 @@
  .I $D(PRCHER) I LCNT>END N DIR S DIR(0)="E" D ^DIR S LCNT=1
  .Q
+ ;PRC*5.1*100: check line items without an FSC or PSC
  D EN106^PRCHNPO7 I $G(ERROR)=1 G EXIT
  I $P($G(^PRC(443.6,PRCHPO,0)),U,13)>0 I $P($G(^PRC(443.6,PRCHPO,23)),U)="" W !!,?5,"This amendment has Est. Shipping and/or Handling charges without any",!,?5,"Est. Shipping BOC." S PRCHER=""
  I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4)=5!($P($G(^(0)),U,4)=15) S CAN=1
  I $G(CAN)'=1 D CHECK^PRCHAMDF(PRCHPO,PRCHAM,.PRCHER)
+ ; 
+ ; Change below to allow checks for monthly limits in file #440.5 before
+ ; completion of the amendment.
+ ;
  I $G(PRCHAUTH)=1!($P($G(^PRC(443.6,PRCHPO,0)),U,2)=25) S FILE=443.6 D  I $G(ERROR) S PRCHER="" K ERROR,FILE
  .D ^PRCHSF3
@@ -107,7 +115,11 @@
  .D REMOVE^PRCSC2(PP410),ENCODE^PRCSC2(PP410,DUZ,.MESSAGE) K MESSAGE
  .I '$G(PRCPROST) W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
- .; Update file #440.5 after amendment has been approved. Consider orders created and amended in the same month and year and the user either
- .; cancels the order or enters other type of amendment that changes the final amount of the order. No credit is given for orders from a
+ .;
+ .; Update file #440.5 after amendment has been approved. Consider orders
+ .; created and amended in the same month and year and the user either
+ .; cancels the order or enters other type of amendment that changes the
+ .; final amount of the order. No credit is given for orders from a
  .; previous month and year. DT is the current date, system-supplied.
+ .;
  .S PRCHCD=$P($G(^PRC(442,PRCHPO,23)),U,8)
  .S PRCNODE=$G(^PRC(442,PRCHPO,6,0)),PRCAMD=$P(PRCNODE,U,3)
@@ -132,7 +144,10 @@
  S SFUND="" I $P($G(^PRC(443.6,PRCHPO,0)),U,19)=2 D SUPP^PRCFFM2M S SFUND=1
  I SFUND=1 W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAM D ^PRCHQUE
+ ;
  D SOURCE^PRCHAMU:$G(SCE)
  G EXIT
-ENC S ER=0
+ ;
+ENC ;Can
+ S ER=0
  D CAN^PRCHMA3
  I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CANCEL !",$C(7) S ER=1 Q
@@ -149,18 +164,24 @@
  S PRCHAMT=-$P(^PRC(443.6,PRCHPO,0),U,15) W !
  QUIT
-APP S %A="   Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
+APP ;App,pr
+ S %A="   Approve Amendment number "_PRCHAM_": ",%B="",%=$S($G(PRCPROST):1,1:2) D ^PRCFYN
  Q
-REV N PRCH
+REV ;Rev
+ N PRCH
  S %=1,%B="",%A="   Review Amendment " D ^PRCHSF3 W ! D ^PRCFYN
  I %=1 S D0=PRCHPO,D1=PRCHAM,PRCH="^PRC(443.6," D ^PRCHDAM
  Q
-EXIT L -^PRC(442,PRCENTRY)
+EXIT ;Ex
+ L -^PRC(442,PRCENTRY)
 EXIT1 K ERROR,FIS,REPO,DEL
  QUIT:$G(PRCPROST)
  I $G(OUT)'=1 G LOOP
  QUIT
-FLAG I $G(FLAG)=1 K FLAG Q
+ ;
+FLAG ;
+ I $G(FLAG)=1 K FLAG Q
  Q
-NOSIGN S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
+NOSIGN ;
+ S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=PRCHAU
 NOSIGN1 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,",DA=PRCHAM,DR="9///@"
  D ^DIE K DIE,DA,DR
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO3.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCHNPO3 ;WISC/RSD/RHD/SC-CONT. OF NEW PO ; 4/23/99 1:39pm
-V ;;5.1;IFCAP;*112*;Oct 20, 2000;Build 2
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  S PRCHSZ=1
@@ -35,12 +35,8 @@
  D SPRMK^PRCHNPO6
  ;
-N Q:'PRCHSZ  K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1
- W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX)
- F  Q:'$F(PRCHX,",,")  S PRCHX=$P(PRCHX,",,",1)_","_$P(PRCHX,",,",2,99) ; *112 remove consecutive commas
- S:$E(PRCHX)="," PRCHX=$E(PRCHX,2,$L(PRCHX)) ; *112 remove leading comma
- S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) ; *112 remove trailing comma
+N Q:'PRCHSZ  K ^TMP($J,"PRCHS"),PRCHSIT S J=0,K=1,PRCHSIT(K)="" G:$D(PRCHPOST) 1 W !?3,"Line Items: " R PRCHX:DTIME G Q:PRCHX["^"!(PRCHX=""),HLP:$E(PRCHX)="?",1:"Aa"[$E(PRCHX)
  F I=1:1 S X=$P(PRCHX,",",I) Q:X=""  I +X'=X S X(1)=$P(X,":",1),X(2)=$P(X,":",2) K:+X(1)'=X(1)!(+X(2)'=X(2))!'(X(1)<X(2)) PRCHX Q:'$D(PRCHX)  S $P(PRCHX,",",I)=X(1)_":1:"_X(2)
  I '$D(PRCHX) W " ??",$C(7) G N
- X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J
+ S:$E(PRCHX,$L(PRCHX))="," PRCHX=$E(PRCHX,1,$L(PRCHX)-1) X "F I="_PRCHX_" D IT Q:'$O(^TMP($J,""PRCHS"",0))" G:'$O(^TMP($J,"PRCHS",0)) N S ^(0)=J
  ;
 3 G 2:J=+^PRCS(410,PRCHSY,10),Q:'$O(^TMP($J,"PRCHS",0)) W !,"A new 2237 will now be created with the following items: " F K=0:0 S K=$O(PRCHSIT(K)) Q:'K  W !?3,PRCHSIT(K)
@@ -89,5 +85,5 @@
  Q
  ;
-VENMSG ;message to alert users that vendors don't match and that IMF will
+VENMSG ;mesasge to alert users that vendors don't match and that IMF will
  ;be updated.
  W !!,"NOTE-Vendors on PO and 2237 don't match.  If you proceed IMF info"," will be used.  If there is no IMF entry for the item for this vendor one will ","be created."
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO5.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;9/5/00  10:59
-V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 EN1 ;FILE 442, FCP #1
@@ -17,5 +17,4 @@
  S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q
  S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1
- I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q
  Q
  ;
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO8.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00  12:30
-V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 EN1 ;FILE 443.6, FCP #1
@@ -15,5 +15,4 @@
  S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q
  S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1
- I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q
  Q
  ;
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPCAR.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCHPCAR ;WISC/AKS-Front End questions for Purchase Card processes ;6/9/96  21:40
- ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
 ASKPO ;Ask If they are processing a purchase or a requisition
  N DIR,Y,PRCHPR,PRCHNE
@@ -83,14 +83,2 @@
  K DA,%A,%B,%
  QUIT
-AOCANPC ;Approving Official Cancel a purchase card order
- N DIC,Y,NREC,X
- W ! S DIC="^PRC(442,",DIC(0)="AEQM"
- S DIC("A")="Select PURCHASE CARD ORDER NUMBER: "
- S DIC("S")="I $P($G(^(7)),U,2)<9,$P($G(^(0)),U,2)=25,($P($G(^(23)),U,11)=""P""!($P($G(^(23)),U,11)=""S""))"
- D ^DIC Q:+Y<0  K DIC
- S %A="Are sure you want to cancel this order",%B="",%=2
- D ^PRCFYN I %<1!(%=2) K %A,%B,% Q
- S DA=+Y,DIE="^PRC(442,",DR=".5///^S X=45" D ^DIE K DIE,DR
- D C2237^PRCH442A
- K DA,%A,%B,%
- QUIT
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHQ4.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCHQ4 ;WOIFO/LKG-RFQ Set up Transmission Records ;7/25/05  15:27
- ;;5.1;IFCAP;**63,114**;Oct 20, 2000;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;5.1;IFCAP;**63**;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
 HE ;Set up Heading segment
  N PRCN0,PRCN1,PRCA,PRCB,PRCZ,DA,DIC,DR,DIQ,X,Y
@@ -95,5 +95,5 @@
  . S PRCD=$G(^PRC(444,PRCDA,2,PRCA,1)),PRCG=$P(PRCB,U)
  . S PRCY="IT^"_PRCG_"^"_$S($P(PRCB,U,6)]"":$P(PRCB,U,6),$P(PRCB,U,5)>0:$P($G(^PRC(441.2,$P(PRCB,U,5),0)),U),1:"")_"^^^",PRCCNT=PRCCNT+1
- . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,2,PRCA,5)),U,2)
+ . I $P($G(^PRC(444,PRCDA,5,0)),U,4)=1,$P($G(^PRC(444,PRCDA,1)),U,8)'="y" S $P(PRCY,U,5)=$P($G(^PRC(444,PRCDA,5)),U,2)
  . S PRCY=PRCY_$P(PRCB,U,9)_"^"_$P(PRCB,U,8)_"^"_($P(PRCB,U,2)*100)_"^^"
  . S PRCE=$P(PRCB,U,3) S:PRCE?1.N PRCH=$P($G(^PRCD(420.5,PRCE,0)),U),$P(PRCY,U,9)=PRCH
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m	(revision 636)
@@ -1,7 +1,5 @@
 PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm
-V ;;5.1;IFCAP;**83,98,112**;Oct 20, 2000;Build 2
+V ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37
  ;Per VHA Directive 2004-038, this routine should not be modified.
- ;External reference to $$GET1^DIQ(4, is supported by ICR# 10090
- ; *112 changes by: VMP, Holloway,T.
  ;
 ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0
@@ -105,11 +103,14 @@
  ;
  S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS)
- S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=%
  ;Std. Turnover
  S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1)
- S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=%
  ;ODI Turnover
  S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2)
- S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=%
  ;All Turnover
  S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL"))
@@ -127,14 +128,17 @@
  ;
  S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL")))
- I %="" S %=0
- S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ I %="" S %=0
+ S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=%
  ;Std. Inactive %
  S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL")))
- I %="" S %=0
- S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ I %="" S %=0
+ S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=%
  ;ODI Inactive %
  S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL")))
- I %="" S %=0
- S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ I %="" S %=0
+ S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=%
  ;All Inactive %
  ;
@@ -158,14 +162,17 @@
  ;
  S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL")))
- I %="" S %=0
- S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ I %="" S %=0
+ S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=%
  ;Std. Long Supply %
  S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL")))
- I %="" S %=0
- S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ I %="" S %=0
+ S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=%
  ;ODI Long Supply %
  S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL")))
- I %="" S %=0
- S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=$J(%,0,2)
+ I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
+ I %="" S %=0
+ S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=%
  ;All Long Supply %
  S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL"))
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPUSEL.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCPUSEL ;WISC/RFJ/DAP-utilities: setup inventory variables ;14 Feb 91
-V ;;5.1;IFCAP;**1,83,110**;Oct 20, 2000;Build 7
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;**1,83**;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;  enter distribution point--input variables:
  ;  prcp("dptype")=distribution point type code [W,P,S]
@@ -20,5 +20,5 @@
  I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q
  ;
- S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$G(PRCP(I)) S %=1 Q
+ S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q
  I '% D DISPLAY Q
  ;
@@ -101,5 +101,5 @@
  ;
  ;
-PARAM(INVPT) ;  set up parameters for inventory point
+PARAM(INVPT)       ;  set up parameters for inventory point
  K PRCP
  N DATA
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSD122.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCSD122 ;WISC/SAW-CONTROL POINT ACT. 2237 TERM. DISP. CON'T ;4/21/93  08:46
-V ;;5.1;IFCAP;**107**;Oct 20, 2000;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  I IOSL-$Y<5 D NEWP^PRCSD121 Q:Z1=U
  W !,"JUSTIFICATION OF NEED OR TURN-IN"
@@ -15,5 +15,5 @@
  W !,?37 K P1 S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1),$P(^(7),U,6)'="" W "/ES/",$$DECODE^PRCSC1(DA)
  N PRSHLB S PRSHLB=^DD(410,40,0) W ?69,! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLB,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,28)
- I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5 W " (",$P(^(.13),U,2),")"
+ I $D(P2),$P(PRSHLB,"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")"
  N PRSHLC S PRSHLC=^DD(410,42,0) K P2 W ?37 I $D(P1),$P(PRSHLC,"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,30)
  W ?69,! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?37 W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?69 I $P(^(7),U,5)'="" S Y=$P(^(7),U,5) D DD^%DT W Y
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP122.m	(revision 636)
@@ -1,4 +1,4 @@
 PRCSP122 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT CON'T ;4/21/93  08:53
-V ;;5.1;IFCAP;**95,107**;Oct 20, 2000;Build 13
+V ;;5.1;IFCAP;**95**;Oct 20, 2000
  ;Per VHA Directive 2004-038, this routine should not be modified.
  I '$D(^PRCS(410,DA,"RM",0)) G DEL
@@ -24,5 +24,5 @@
  K P1 W !,?39,"|" S:$P(^PRCS(410,DA,7),U,3)'="" (P,P1)=$P(^(7),U,3) I $D(P1) W "/ES/",$$DECODE^PRCSC1(DA)
  N PRSHLE S PRSHLE=^DD(410,40,0) W ?72,"|",! I $P(^PRCS(410,DA,7),U)'="" S (P,P2)=$P(^(7),U) I $P(PRSHLE,"^",2)[200,$D(^VA(200,P,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,31)
- I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>5 W " (",$P(^(.13),U,2),")"
+ I $D(P2),$P(^DD(410,40,0),"^",2)[200,$D(^VA(200,+P2,.13)),$L($P(^(.13),U,2))'>4 W " (",$P(^(.13),U,2),")"
  K P2 W ?39,"|" I $D(P1),$P(^DD(410,42,0),"^",2)[200,$D(^VA(200,P1,20)),$P(^(20),U,2)]"" W $E($P(^(20),U,2),1,33)
  W ?72,"|",! W:$P(^PRCS(410,DA,7),U,2)'="" $P(^(7),U,2) W ?39,"|" W:$P(^(7),U,4)'="" $P(^(7),U,4) W ?72,"|" S Y=$S($P(^(7),U,7):$P(^(7),U,7),1:$P(^(7),U,5)) I Y D DD^%DT W Y
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1A.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1A.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1A.m	(revision 636)
@@ -1,4 +1,21 @@
 PRCSP1A ;WISC/SAW/BGJ-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;5/1/92  9:20 AM [2/18/99 9:02am]
-V ;;5.1;IFCAP;**90**;Oct 20, 2000
+ ;;5.1;IFCAP;**90**;Oct 20, 2000;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;Per VHA Directive 10-93-142, this routine should not be modified.
 CPB ;CP BAL
@@ -60,5 +77,5 @@
 HDR2 S P=P+1 W @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$P(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P,! Q
 HOLD G HDR:$E(IOST,1,2)'="C-"
-CRT W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U I ((Z1'=U)&&('$D(C1)))  D HDR
+CRT W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U I ((Z1'=U)&('$D(C1)))  D HDR
  Q
 CTR ;CEILING TRANS
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG1.m	(revision 636)
@@ -1,5 +1,5 @@
 PRCSRIG1 ;WISC/SAW/KMB/LJP/SC-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ;3-3-93/14:30 ; 3/31/05 3:48pm
-V ;;5.1;IFCAP;**13,81,101,110**;Oct 20, 2000;Build 7
- ;Per VHA Directive 2004-038, this routine should not be modified.
+V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;PRC*5.1*81, RIL that originated thru DynaMed is NOT allowed to be
@@ -33,4 +33,5 @@
 SV ;
  I (IO'=IO(0))!($D(ZTQUEUED)) D ^%ZISC
+ G EXIT:$D(ZTQUEUED)
  ;patch *81 -DynaMed trx. is not allowed to be re-used
  N PRCVSY,PRCVID
@@ -38,5 +39,4 @@
  I PRCVSY=1 S PRCVID=$$ITDMID(PRCSRID0)
  I PRCVSY=1,PRCVID=1 G CHK1
- G EXIT:$D(ZTQUEUED)
  U IO(0) S %=2 W !,"Do you wish to re-use this list " D YN^DICN G:%=1 JMP G:%=0 SV
 CHK1 I PRCSCT=PRCSCT(1) S DIK="^PRCS(410.3,",DA=PRCSRID0 D ^DIK G CLS
Index: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCST5.m
===================================================================
--- FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCST5.m	(revision 631)
+++ FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCST5.m	(revision 636)
@@ -1,3 +1,3 @@
-PRCST5 ; GENERATED FROM 'PRCS APPROVE REQUEST' PRINT TEMPLATE (#299) ; 11/15/05 ; (FILE 410, MARGIN=80)
+PRCST5 ; GENERATED FROM 'PRCS APPROVE REQUEST' PRINT TEMPLATE (#299) ; 04/11/06 ; (FILE 410, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/IHS_ROUTINES-AUP/AUPNPAT.m
===================================================================
--- FOIAVistA/trunk/r/IHS_ROUTINES-AUP/AUPNPAT.m	(revision 631)
+++ FOIAVistA/tag/r/IHS_ROUTINES-AUP/AUPNPAT.m	(revision 636)
@@ -1,18 +1,119 @@
-AUPNPAT ;IHS/OHPRD/EDE - POST SELECTION SETS FOR PATIENT LOOKUP ; 24-MAY-1993
- ;;1.0;PCE PATIENT CARE ENCOUNTER;;Aug 12, 1996
- ;;93.2;IHS PATIENT DICTIONARIES.;;JUL 01, 1993
+AUPNPAT ; IHS/CMI/LAB - POST SELECTION SETS FOR PATIENT LOOKUP ;10/10/06  08:57
+ ;;1.0;PCE PATIENT CARE ENCOUNTER;**167**;Aug 12, 1996;Build 22
+ ; Modified from FOIA RPMS,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
  ; This routine sets standard patient variables
- ;
+ ;IHS/SET/GTH AUPN*99.1*8 10/04/2002 Removed all refs to AUPN*93.2*3.
 START ;
  S:$D(X) AUPNPATX=X
  S AUPNPAT=+Y
  S AUPNSEX=$P(^DPT(AUPNPAT,0),U,2),AUPNDOB=$P(^(0),U,3),AUPNDOD="" S:$D(^(.35)) AUPNDOD=$P(^(.35),U,1)
- S X2=AUPNDOB,X1=$S('AUPNDOD:DT,AUPNDOD:AUPNDOD,1:DT) D ^%DTC S AUPNDAYS=X K X,X1,X2
+ S X2=AUPNDOB,X1=$S('AUPNDOD:DT,AUPNDOD:AUPNDOD,1:DT)
+ D ^%DTC
+ S AUPNDAYS=X
+ K X,X1,X2
  S:$D(AUPNPATX) X=AUPNPATX
  K %T,%Y,AUPNPATX
+ ;New EHR code    ;DAOU/WCJ   2/8/05
+ ; VOE change to permit VA, IHS and VOE to use the same code
+ Q:$G(DUZ("AG"))="V"  ; WV/CJS
+ ;End EHR modifications
+ S DFN=AUPNPAT
+ S SSN=$$SSN(AUPNPAT)
+ S AGE=$$AGE(AUPNPAT)
+ S DOB=$$DOB(AUPNPAT)
+ S SEX=$$SEX(AUPNPAT)
  Q
  ;
-KILL ; KILL VARIABLES SET BY THIS ROUTINE
+KILL ;PEP - KILL VARIABLES SET BY THIS ROUTINE
  K AUPNPAT,AUPNSEX,AUPNDOB,AUPNDOD,AUPNDAYS
+ ;New EHR code    ;DAOU/WCJ   2/8/05
+ ; VOE change to permit VA, IHS and VOE to use the same code
+ Q:$G(DUZ("AG"))'="E"
+ ;End EHR modifications
+ K AGE,DFN,DOB,SEX,SSN
  Q
+ ;
+ ;  NOTE TO PROGRAMMERS:
+ ;   All parameters are required, except the Format parameter ("F").
+ ;   The default for the Format parameter is the internal format of
+ ;   the returned value.
+ ;
+AGE(DFN,D,F) ;PEP - Given DFN, return Age.
+ ;return age on date d in format f (defaults to DT and age in years)
+ Q $$AGE^AUPNPAT3(DFN,$G(D),$G(F))
+ ;
+BEN(DFN,F) ;PEP - returns classifications/beneficiary in format F.
+ Q $$BEN^AUPNPAT3(DFN,$G(F))
+ ;
+BENYN(DFN) ;PEP - Return BEN/Non-BEN Status.
+ Q $$BEN^AUPNPAT1(DFN)
+ ;
+CDEATH(DFN,F) ;PEP - returns Cause of Death in F format
+ Q $$CDEATH^AUPNPAT3(DFN,$G(F))
+ ;
+COMMRES(DFN,F) ;PEP - Given DFN, return comm of res in F format
+ Q $$COMMRES^AUPNPAT3(DFN,$G(F))
+ ;
+DEC(PID) ;PEP - RETURN DECRYPTED PATIENT IDENTIFIER
+ G DEC^AUPNPAT4
+ ;----------
+ENC(DFN) ;PEP
+ G ENC^AUPNPAT4
+ ;----------
+DOB(DFN,F) ;PEP - Given DFN, return Date of Birth according to F.
+ Q $$DOB^AUPNPAT3(DFN,$G(F))
+ ;
+DOD(DFN,F) ;PEP - Given DFN, return Date of Death in FM format.
+ Q $$DOD^AUPNPAT3(DFN,$G(F))
+ ;
+ELIGSTAT(DFN,F) ;PEP - returns eligibility status in F format
+ Q $$ELIGSTAT^AUPNPAT3(DFN,$G(F))
+ ;
+HRN(DFN,L,F) ;PEP
+ ;f patch 4 05/08/96
+ Q $$HRN^AUPNPAT3(DFN,L,$G(F))
+ ;
+MCD(P,D) ;PEP - Is patient P medicaid eligible on date D?
+ Q $$MCD^AUPNPAT2(P,D)
+ ;
+MCDPN(P,D,F) ;PEP - return medicaid plan name for patient P on date D in form F.
+ Q $$MCDPN^AUPNPAT2(P,D,$G(F))
+ ;
+MCR(P,D) ;PEP - Is patient P medicare eligible on date D?
+ Q $$MCR^AUPNPAT2(P,D)
+ ;
+PI(P,D) ;PEP - Is patient P private insurance eligible on date D?
+ Q $$PI^AUPNPAT2(P,D)
+ ;
+PIN(P,D,F) ;PEP - return private insurer name for patient P on date D in form F.
+ Q $$PIN^AUPNPAT2(P,D,$G(F))
+ ;
+SEX(DFN) ;PEP - Given DFN, return Sex.
+ Q $$SEX^AUPNPAT3(DFN)
+ ;
+SSN(DFN) ;PEP - Given DFN, return SSN.
+ Q $$SSN^AUPNPAT3(DFN)
+ ;
+TRIBE(DFN,F) ;PEP - Given DFN, return Tribe in F format
+ Q $$TRIBE^AUPNPAT3(DFN,$G(F))
+ ;
+ ;Begin New Code;IHS/SET/GTH AUPN*99.1*8 10/04/2002
+RR(P,D) ;PEP -  Is patient P railroad eligible on date D?
+ Q $$RRE^AUPNPAT2(P,D)
+ ;End New Code;IHS/SET/GTH AUPN*99.1*8 10/04/2002
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBAPIP.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGBAPIP.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBAPIP.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGBAPIP ;WOIFO/MLH - Background Processor API to build queues - Modules for place
- ;;3.0;IMAGING;**1,7,8,20,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**1,7,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -17,11 +16,11 @@
  ;; +---------------------------------------------------------------+
  ;;
-DUZ2PLC(WARN) ;Convert DUZ to a PLACE. File 2006.1 entry (PLACE)
- ; Extrinsic : Always returns a PLACE
- ; WARN          : message about where the PLACE was derived from.
+DUZ2PLC(WARN) ; Moved from MAGGTU3 v2.5 - DBI - SEB Patch 4
+ ; Extrinsic : Always returns a PLACE /gek 8/2003
+ ; WARN          : message about where the PLACE was derived from.  /gek 8/2003
  ; Compute the Users Institution for older versions of Imaging Display workstation.
- ; This is called when DUZ(2) doesn't exist Or Can't resolve DUZ(2)
- ;  into site param entry.  This solved a GateWay Problem where DUZ(2) didn't
- ;  exist.  - Shouldn't get here anymore, that was fixed.
+ ; This is called when : 
+ ;               DUZ(2) doesn't exist, 
+ ;               Or Can't resolve DUZ(2) into site param entry
  N MAGINST,DIVDTA,PLACE
  S MAGINST=0
@@ -38,10 +37,11 @@
  Q PLACE
  ;
-DA2PLC(MAGDA,TYPE) ; Get Place from Image File IEN
+DA2PLC(MAGDA,TYPE) ; Moved from MAGGTU7 v2.5 - DBI - SEB Patch 4
  ; TYPE :        Possible values "A" Abstract, "F" Full Res or "B" Big File
  ; (defaults to "F" if null)
- ; Resolve Place (PLC) using the Acquisition Site field (ACQS)
- ; IF ACQS is null or not doesn't exist in the site parameter file
- ; THEN Resolve PLC using NetWork Location pointer
+ ; Resolve current place of image using the Acquisition Site field, then
+ ; resolve current place of image using NetWork Location pointer
+ ; if the Acquisition Site field is null or not related to the site 
+ ; parameter file.
  ; 
  N MAGREF,MAG0,FBIG,SITE,PLC,MAGJB
@@ -49,7 +49,6 @@
  S SITE=$P($G(^MAG(2005,MAGDA,100)),U,3)
  I SITE S PLC=$$PLACE^MAGBAPI(SITE) Q:PLC PLC
- ; p59  Stop the error when an Image is Deleted.
- S MAG0=$G(^MAG(2005,MAGDA,0)) Q:MAG0="" 0
- ;
+ S MAG0=^MAG(2005,MAGDA,0)
+ ;I '$D(TYPE) S TYPE="F" /gek 8/2003  mod for efficiency (from ed)
  S TYPE=$E($G(TYPE)_"F",1)
  I "AF"[TYPE D
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBRTE5.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGBRTE5.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBRTE5.m	(revision 636)
@@ -23,5 +23,5 @@
  . N CP,M1,M2,MAX,B,E,L,RD,T
  . ;
- . L +^MAGRT(2006.5906,0):1E9 ; Background task must wait for lock
+ . L +^MAGRT(2006.5906,0):19 ; Background task must wait for lock
  . ;
  . ; Clean up old info
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBRTUT.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGBRTUT.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGBRTUT.m	(revision 636)
@@ -117,5 +117,5 @@
  N D0,MORE,N,P1,P4,P5,P6,P7,P8,TIME
  S TIME=$$STAMP($H)+55,N=0,MORE=0
- L +^MAGQUEUE(2006.03,0):1E9 ; Background process must wait
+ L +^MAGQUEUE(2006.03,0):19 ; Background process must wait
  S D0="" F  S D0=$O(^MAGQUEUE(2006.03,"B","EVAL",D0)) Q:D0=""  D  Q:MORE
  . S X=$G(^MAGQUEUE(2006.03,D0,0))
@@ -168,5 +168,5 @@
  I KEY'=5,KEY'=6 S OUT="-3,Invalid key specified ("_KEY_")" Q
  ;
- L +^MAG(2006.587,0):1E9 ; Background process MUST wait
+ L +^MAG(2006.587,0):19 ; Background process MUST wait
  S (N,D0)=0 F  S D0=$O(^MAG(2006.587,D0)) Q:'D0  D
  . S X=$G(^MAG(2006.587,D0,0)),ID=$P(X,"^",KEY) Q:ID'=OLD
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDHL7.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGDHL7.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDHL7.m	(revision 636)
@@ -136,5 +136,5 @@
  N D0,HDR
  S DATE=DATE\1
- L +^MAGDHL7(2006.5,0):1E9 ; Background process MUST wait
+ L +^MAGDHL7(2006.5,0):19 ; Background process MUST wait
  S D0=$O(^MAGDHL7(2006.5," "),-1)+1
  S ^MAGDHL7(2006.5,D0,0)=DATE
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDRPC3.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGDRPC3.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGDRPC3.m	(revision 636)
@@ -133,5 +133,5 @@
  . Q
  ;
- L +^MAGDOUTP(2006.574,0):1E9 ; Background process MUST wait
+ L +^MAGDOUTP(2006.574,0):19 ; Background process MUST wait
  S P=$P($G(^MAG(2005,IMAGE,0)),"^",10),P=$S(P:P,1:IMAGE)
  S STUID=$P($G(^MAG(2005,P,"PACS")),"^",1) S:STUID="" STUID="?"
@@ -199,5 +199,5 @@
  Q:OLD 1
  ;
- L +^MAGDOUTP(2006.574,D0,1,0):1E9 ; Background Process MUST wait
+ L +^MAGDOUTP(2006.574,D0,1,0):19 ; Background Process MUST wait
  S X=$G(^MAGDOUTP(2006.574,D0,1,0))
  S $P(X,"^",1,2)="^2006.5744"
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNLKP.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGNLKP.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNLKP.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGNLKP ;WOIFO/GEK - Lookup from delphi into any file ; [ 06/20/2001 08:56 ]
- ;;3.0;IMAGING;**8,92,46,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8,92**;Jan 10, 2007;Build 1
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -36,4 +36,5 @@
  ;                       Defaults to "B"
  ;    
+ ;
  N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGNTI ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002  2:37 PM
- ;;3.0;IMAGING;**10,8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**10,8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -20,5 +20,4 @@
  ; Call to file TIU and Imaging Pointers
  ; TIU API to add image to TIU
- N X
  I $P(^TIU(8925,TIUDA,0),U,2)'=$P(^MAG(2005,MAGDA,0),U,7) S MAGRY="0^Patient Mismatch." Q
  D PUTIMAGE^TIUSRVPL(.MAGRY,TIUDA,MAGDA) ;
@@ -28,16 +27,14 @@
  ; DONE.
  S MAGRY="1^Image pointer filed successfully"
- ; Now we save the PARENT ASSOCIATION Date/Time 
- D LINKDT^MAGGTU6(.X,MAGDA)
  Q
 DATA(MAGRY,TIUDA) ;RPC [MAG3 TIU DATA FROM DA]
  ; Call to get TIU data from the TIUDA
- ; Return =     TIUDA^Document Type ^Document Date^DFN^Author DUZ
+ ; Return =     TIUDA^Document Type ^Document Date^DFN
  ;
- S MAGRY=TIUDA_U_$$GET1^DIQ(8925,TIUDA,".01","E")_U_$$GET1^DIQ(8925,TIUDA,"1201","I")_U_$$GET1^DIQ(8925,TIUDA,".02","I")_U_$$GET1^DIQ(8925,TIUDA,"1202","I")_U
+ S MAGRY=TIUDA_U_$$GET1^DIQ(8925,TIUDA,".01","E")_U_$$GET1^DIQ(8925,TIUDA,"1201","I")_U_$$GET1^DIQ(8925,TIUDA,".02","I")
  Q
 IMAGES(MAGRY,TIUDA) ;RPC [MAG3 CPRS TIU NOTE]
  ; Call to get all images for a given TIU DA
- ; We first get all Image IEN's breaking groups into separate images
+ ; We first get all Image IEN's breaking groups into seperate images
  ; Then get Image Info for each one.
  ; MAGRY    -     Return array of Image Data entries
@@ -47,5 +44,5 @@
  ;
  ; Call TIU API to get list of Image IEN's
- N MAGARR,CT,TCT,I,J,Z K ^TMP($J,"MAGGX")
+ N MAGARR,CT,TCT K ^TMP("MAGGX",$J)
  N DA,MAGQI,MAGNCHK,MAGXX,MAGRSLT
  N TIUDFN,MAGQUIT ; MAGQI 8/22/01
@@ -78,16 +75,16 @@
  . . ;   children.  Later when list is looped through, it's INFO^MAGGTII will be in 
  . . ;   list.  Have to do this to allow other images in list from TIU to be processed.
- . . D CHK^MAGGSQI(.MAGQI,DA) I 'MAGQI(0) S CT=CT+1,^TMP($J,"MAGGX",CT)=DA Q
+ . . D CHK^MAGGSQI(.MAGQI,DA) I 'MAGQI(0) S CT=CT+1,^TMP("MAGGX",$J,CT)=DA Q
  . . S J=0 ; the following line needs to take only the first piece of the node - PMK 4/4/02
- . . F  S J=$O(^MAG(2005,DA,1,J)) Q:'J  S CT=CT+1,^TMP($J,"MAGGX",CT)=$P(^(J,0),"^")
+ . . F  S J=$O(^MAG(2005,DA,1,J)) Q:'J  S CT=CT+1,^TMP("MAGGX",$J,CT)=$P(^(J,0),"^")
  . S CT=CT+1
- . S ^TMP($J,"MAGGX",CT)=DA
+ . S ^TMP("MAGGX",$J,CT)=DA
  ; Now get image info for each image
  ;
  S Z=""
  S MAGQUIET=1
- F  S Z=$O(^TMP($J,"MAGGX",Z)) Q:Z=""  D
- . S TCT=TCT+1,MAGXX=^TMP($J,"MAGGX",Z)
- . ;GEK 8/24/00 Stopping the Invalid Image IEN's and Deleted Images
+ F  S Z=$O(^TMP("MAGGX",$J,Z)) Q:Z=""  D
+ . S TCT=TCT+1,MAGXX=^TMP("MAGGX",$J,Z)
+ . ;GEK 8/24/00 Stoping the Invalid Image IEN's and Deleted Images
  . I '$D(^MAG(2005,MAGXX)) D  Q
  . . D INVALID^MAGGTIG(MAGXX,.MAGRSLT) S MAGRY(CT)=MAGRSLT
@@ -96,5 +93,5 @@
  K MAGQUIET
  S MAGRY(0)=TCT_"^"_TCT_" Images for the selected TIU NOTE"
- ; Put the Image IEN of the last image into the group IEN field.
+ ; PUT THE Image IEN of the last image into the group ien field.
  Q:'TCT
  S $P(MAGRY(0),U,3)=TIUDA
@@ -103,5 +100,5 @@
  S $P(MAGRY(0),U,4)=$$GET1^DIQ(8925,TIUDA,".02","E")_"  "_$P(MAGRSLT,U,2)_"  "_$$FMTE^XLFDT($P(MAGRSLT,U,3),"8")
  ;
- S $P(MAGRY(0),U,5)=$S($P($G(MAGFILE),U):$P(MAGFILE,U),$G(MAGXX):MAGXX,1:0)
+ S $P(MAGRY(0),U,5)=$S($P($G(MAGFILE),U):$P(MAGFILE,U),1:MAGXX)
  Q
  ;. S Z=ISDELIMG(DA) I Z S TCT=TCT+1,MAGRY(TCT)="B2^"_$P(Z,U,2) Q
@@ -123,38 +120,2 @@
  S $P(Z,U,17)=$P(MAGR,U,2)
  Q Z
-ISDOCCL(MAGRY,IEN,TIUFILE,CLASS) ;RPC [MAGG IS DOC CLASS]
- ;Checks to see if IEN of TIU Files 8925 or 8925.1 is of a certain Doc Class 
- ;MAGRY  = Return String  
- ;                 for Success   "1^message"
- ;                 for Failure   "0^message"
- ;IEN    = Internal Entry Number in the TIUFILE
- ;TIUFILE = either 8925   if we need to see if a Note is of a Document Class 
- ;            or   8925.1 if we need to see if a Title is of a Document Class
- ;CLASS  = Text Name of the Document Class   example: "ADVANCE DIRECTIVE"
- ;
- S MAGRY="0^Unknown Error checking TIU Document Class"
- K MAGTRGT,DEFIEN,DOCCL,RES,DONE,NTTL
- S DONE=0
- ; If we're resolving a Title
- I TIUFILE="8925.1" D  Q:DONE
- . S DEFIEN=IEN,NTTL="Title"
- . I '$D(^TIU(8925.1,DEFIEN,0)) S MAGRY="0^Invalid Title IEN",DONE=1 Q
- . Q
- ; If we're resolving a Note
- I TIUFILE="8925" D  Q:DONE
- . S NTTL="Note"
- . I '$D(^TIU(8925,IEN)) S MAGRY="0^Invalid Note IEN",DONE=1 Q
- . ; Get Title IEN from Note IEN
- . S DEFIEN=$$GET1^DIQ(8925,IEN_",",.01,"I")
- . I DEFIEN="" S MAGRY="0^Error resolving Document Class from Note IEN" S DONE=1 Q
- . Q
- ;
- ; Find the IEN in 8925.1 for Document Class (CLASS) 
- D FIND^DIC(8925.1,"","@;.001","X",CLASS,"","","I $P(^(0),U,4)=""DC""","","MAGTRGT")
- S DOCCL=$G(MAGTRGT("DILIST",2,1))
- ;
- ; See if ^TIU(8925.1,DEFIEN is of Document Class DOCCL
- S RES=$$ISA^TIULX(DEFIEN,DOCCL)
- I RES S MAGRY="1^The "_NTTL_" is of Document Class "_CLASS Q
- S MAGRY="0^The "_NTTL_" is Not of Document Class "_CLASS
- Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI1.m	(revision 636)
@@ -1,4 +1,4 @@
-MAGGNTI1 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002  2:37 PM
- ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20
+MAGGNTI1 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 20 Nov 2006  12:42 PM
+ ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023
  ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -16,5 +15,5 @@
  ;; | to be a violation of US Federal Statutes.                     |
  ;; +---------------------------------------------------------------+
- ;;      
+ ;;
  Q
 NEW(MAGRY,MAGDFN,MAGTITLE,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGLOC,MAGDATE,MAGCNSLT,MAGTEXT) ;RPC [MAG3 TIU NEW]
@@ -37,5 +36,5 @@
  ;  MAGESBY  - The DUZ of the Signer (Defaults to DUZ)
  ;  MAGADCL  - 1 = Mark this Note as Administratively Closed
- ;  MAGMODE  - Mode of Admin Closure: "S" = Scanned Document 
+ ;  MAGMODE  - Mode of Admin Closure: "S" = Scanned Document
  ;             "M" = Manual closure, "E" = Electronically Filed
  ;  MAGDATE  - Date of the Note. For New Notes.
@@ -55,5 +54,5 @@
  I "MSE"'[MAGMODE S MAGRY="0^Invalid Mode of Closure: """_MAGMODE_"""" Q
  ;
- ;       Here if we have no Text, we'll add at least a line.
+ ; Here if we have no Text, we'll add at least a line.
  I $O(MAGTEXT(""))="" S MAGTEXT(.1)="   VistA Imaging - - Scanned Document"
  ;               Reformat Text - "TEXT",i,0)"   for TIU Call.
@@ -97,7 +96,6 @@
  I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_"  "_MAGRES
  E  S MTXT(1301)=MAGDATE
- ; - Fix in T30,  if DUZ isn't MAGESBY, we have Author different than User.
- I MAGESBY'=DUZ S MTXT("1202")=MAGESBY
- ;               Update and LINK TO CONSULT if needed.
+ ;
+ ; Update and LINK TO CONSULT if needed.
  I MAGISC S MTXT("1405")=MAGCNSLT_";GMR(123,"
  I $D(MTXT) D  I 'MUPD S MAGRY=MUPD Q
@@ -105,5 +103,5 @@
  . Q
  ;
- ;               If Admin Close, then We quit.
+ ; If Admin Close, then We quit.
  I MAGADCL="1" D  Q
  . D ADMNCLOS^MAGGNTI2(.MAGTY,MAGDFN,MAGTIUDA,MAGMODE)
@@ -111,5 +109,5 @@
  . Q
  ;
- ;               if caller sent esignature to Sign this Note.
+ ; if caller sent esignature to Sign this Note.
  I $L(MAGES) D
  . D SIGN^MAGGNTI3(.MAGTY,MAGDFN,MAGTIUDA,MAGES,MAGESBY)
@@ -143,5 +141,5 @@
  ;
  I '$$VALDATA^MAGGNTI2(.MAGRY,MAGDFN,MAGTIUDA) Q
- N MAGXT,I,CT,NEWTIUDA,MAGY,MAGRES,MAGUPD
+ N MAGXT,I,CT,NEWTIUDA,MAGY,MAGRES
  S CT=1,I=""
  S MAGXT("TEXT",1,0)="VistA Imaging  Scanned Document - Addendum."
@@ -153,20 +151,17 @@
  D MAKEADD^TIUSRVP(.MAGRY,MAGTIUDA,.MAGXT)
  ; MAGRY could be 0^error message
- ;       -1^message
- ;       TIUDA
+ ;                                -1^message
+ ;                                TIUDA
  I $P(MAGRY,"^")<0 S $P(MAGRY,"^")=0 Q
  S NEWTIUDA=+MAGRY
  S MAGRY=MAGRY_"^Addendum was created."
- ;
+ ;       
  ;Put in the Date that was sent.
- K MAGUPD
  I '$$VALID^MAGGSIV1(8925,1301,.MAGDATE,.MAGRES) S MAGRY=MAGRY_"  "_MAGRES
  E  D
- . S MAGUPD(1301)=MAGDATE
- . S MAGUPD(1211)=$$GET1^DIQ(8925,1211,MAGTIUDA,"I")
- ; - Fix in T30,  if DUZ isn't MAGESBY, we have Author different than User.
- I MAGESBY'=DUZ S MAGUPD("1202")=MAGESBY
- I $D(MAGUPD) D
- . D UPDATE^TIUSRVP(.MAGY,NEWTIUDA,.MAGUPD)
+ . K X
+ . S X(1301)=MAGDATE
+ . S X(1211)=$$GET1^DIQ(8925,1211,MAGTIUDA,"I")
+ . D UPDATE^TIUSRVP(.MAGY,NEWTIUDA,.X)
  . I 'MAGY S MAGRY=MAGRY_" TIU Data was Not Correctly Filed."
  . Q
@@ -185,6 +180,4 @@
  Q
 MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE]
- ; After a Note is filed, we call this to Modify the Note.  We do this to sign it.
- ;  That way the Signed Date is After the Image Association  Date/Time.
  N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0)
  S MAGDFN=$G(MAGDFN),MAGTIUDA=$G(MAGTIUDA)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI2.m	(revision 636)
@@ -1,19 +1,19 @@
-MAGGNTI2 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002  2:37 PM
- ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+MAGGNTI2 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 20 Nov 2006  12:18 PM
+ ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
- ;; | Property of the US Government.        |
+ ;; | Property of the US Government.                                |
  ;; | No permission to copy or redistribute this software is given. |
  ;; | Use of unreleased versions of this software requires the user |
- ;; | to execute a written test agreement with the VistA Imaging |
- ;; | Development Office of the Department of Veterans Affairs,  |
- ;; | telephone (301) 734-0100.          |
+ ;; | to execute a written test agreement with the VistA Imaging    |
+ ;; | Development Office of the Department of Veterans Affairs,     |
+ ;; | telephone (301) 734-0100.                                     |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
  ;; | Modifications to this software may result in an adulterated   |
  ;; | medical device under 21CFR820, the use of which is considered |
- ;; | to be a violation of US Federal Statutes.      |
+ ;; | to be a violation of US Federal Statutes.                     |
  ;; +---------------------------------------------------------------+
- ;;      
+ ;;
  Q
 LIST(MAGRY,CLASS,MYLIST) ; RPC [MAG3 TIU LONG LIST OF TITLES]
@@ -26,5 +26,5 @@
  ;                               TIU PERSONAL TITLE LIST       PERSLIST^TIUSRVD 
  ;                                       
- ; Note : sending CLASS IEN isn't used in p59.
+ ; Note : sending CLASS IEN isn't tested.
  ; 
  K MAGRY
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI3.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGNTI3.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGNTI3.m	(revision 636)
@@ -1,5 +1,5 @@
-MAGGNTI3 ;WOIFO/GEK - Imaging interface to TIU. RPC Calls etc. ; 04 Apr 2002  2:37 PM
- ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+MAGGNTI3 ;WOIFO/GEK - Imaging interface to TIU RPC Calls etc. ; 04 Apr 2002  2:37 PM
+ ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -15,5 +15,5 @@
  ;; | to be a violation of US Federal Statutes.                     |
  ;; +---------------------------------------------------------------+
- ;;      
+ ;;
  Q
 MOD(MAGRY,MAGDFN,MAGTIUDA,MAGADCL,MAGMODE,MAGES,MAGESBY,MAGTEXT) ; RPC [MAG3 TIU MODIFY NOTE]
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIA.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGSIA.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIA.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGSIA ;WOIFO/GEK - Imaging RPC Broker calls. Add/Modify Image entry ; [ 12/27/2000 10:49 ]
- ;;3.0;IMAGING;**7,21,8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,21,8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -45,5 +44,5 @@
  ;    CALLING ROUTINE is responsible for RENAMING THE IMAGE FILE on DISK
  ;      TO THE NEW FILE NAME RETURNED BY THIS CALL.
- ;      Changed to include hierarchical directory hash  - PMK 04/23/98
+ ;      Changed to include hierarchial directory hash  - PMK 04/23/98
  ;----------------------------------------------------------------
  N MAGGFDA,MAGGDRV,MAGGRP,MAGCHLD,GRPCT,MAGGDA,MAGGFNM
@@ -64,5 +63,4 @@
  I '$D(MAGGFDA(2005,"+1,")) S MAGRY(0)="0^No data to file.  Operation CANCELED." Q
  ;
- ;Q:'$$VALINDEX^MAGGSIV1(.MAGRY,$G(MAGGFDA(2005,"+1,",42)),$G(MAGGFDA(2005,"+1,",44)),$G(MAGGFDA(2005,"+1,",43)))
  ;  Check on some possible problems: required fields, create default values etc.
  D PRE^MAGGSIA1(.MAGERR,.MAGGFDA,MAGGRP,.MAGGDRV,.MAGREF) I $L(MAGERR) S MAGRY(0)=MAGERR Q
@@ -88,5 +86,5 @@
  ; IF a group, UpDate the GROUP PARENT in each Group Object and QUIT
  ;  The Return (MAGRY(0)) will be IEN with NO Filename. Groups don't get Filename
- I MAGGRP D  G C1
+ I MAGGRP D  Q
  . D UPDCHLD^MAGGSIM(.MAGCHLD,MAGGDA)
  . S MAGRY(0)=MAGGDA_U
@@ -95,8 +93,10 @@
  ; ENTRY in Image File has been made, if any errors from here on
  ;  then we have to delete the image entry.
- ;  IF This image is a member of a Group, Update the Group Entry with new child.
- S X=$G(MAGGFDA(2005,"+1,",14)) I +X D  I $L(MAGERR) Q
- . D UPDPAR^MAGGSIM(.MAGERR,X,.MAGACT,MAGGDA)
- . I $L(MAGERR) S MAGRY(0)=MAGERR D CLEAN
+ ; New Index Field Check.  If this entry doesn't have the Index fields introduced
+ ;   in 3.0.8 then we use the Patch 17 conversion API call to generate default values.
+ ;-This is being deferred to a later patch.
+ ;-I '$D(^MAG(2005,MAGGDA,40)) D
+ ;-. D ONE^MAGSCNVI(MAGGDA)
+ ;-. D ACTION^MAGGTAU("DFTINDX^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA)
  ;
  ; Now generate the Image FileName. This is passed back to the calling app, 
@@ -120,52 +120,27 @@
  . . D CLEAN
  ;
-C1 ; 59 
- K MAGGFDA ; P59.
- ;P59 Now we Auto-Generate the Index Fields, if they don't exist for this entry
- I '$D(^MAG(2005,MAGGDA,40)) D
- . N INDXD
- . D GENIEN^MAGXCVI(MAGGDA,.INDXD)
- . D COMIEN^MAGXCVC(MAGGDA,.INDXD)
- . S ^MAGIXCVT(2006.96,MAGGDA)=1 ; Flag. Says fields were converted by index generation
- . ; TRKING ID  TRKID =   MAGGFDA(2005,"+1,",108)
- . ;;D ACTION^MAGGTAU("GENINDX^"_MAGGFDA(2005,"+1,",5)_"^"_MAGGDA_"$$"_MAGGFDA(2005,"+1,",108))
- . D ACTION^MAGGTAU("INDEX-ALL^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA_"$$"_$P(^MAG(2005,MAGGDA,100),"^",5))
- . Q
  ;
- ;P59 If TYPE INDEX is missing we Auto-Generate Index Type and other missing Index Term values.
- I '$P(^MAG(2005,MAGGDA,40),"^",3) D
- . N INDXD,OLD40,N40
- . S (N40,OLD40)=^MAG(2005,MAGGDA,40)
- . D GENIEN^MAGXCVI(MAGGDA,.INDXD)
- . ; If Origin doesn't exist in existing, this will put V in. 
- . I $P(INDXD,"^",6)="" S $P(INDXD,"^",6)="V"
- . ; We're not changing existing values of Spec,Proc or Origin 
- . F J=1:1:6 I '$L($P(N40,"^",J)) S $P(N40,"^",J)=$P(INDXD,"^",J)
- . ;Validate the merged Spec and Proc, if  not valid, revert back to old Spec and Proc
- . I '$$VALINDEX^MAGGSIV1(.X,$P(N40,"^",3),$P(N40,"^",5),$P(N40,"^",4)) S $P(N40,"^",4,5)=$P(OLD40,"^",4,5)
- . S ^MAG(2005,MAGGDA,40)=N40
- . ;;D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108))
- . D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA_"$$"_$P(^MAG(2005,MAGGDA,100),"^",5))
- . D ENTRY^MAGLOG("INDEX-42",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1)
- . Q
+ ;
+ ;  IF This image is a member of a Group, Update the Group Entry with new child.
+ S X=$G(MAGGFDA(2005,"+1,",14)) I +X D  I $L(MAGERR) Q
+ . D UPDPAR^MAGGSIM(.MAGERR,X,.MAGACT,MAGGDA)
+ . I $L(MAGERR) S MAGRY(0)=MAGERR D CLEAN
+ ;
  ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. 
  ;** RPC =-> 'MAG ABSJB' after abstract is/isn't created on the workstation
  ;
  ;  The Return is:  IEN ^ DRIVE:DIR ^ FILE.EXT [^ DRIVE:DIR ^ FILE.BIG]
- ;   example:  487^C:\IMAGE\^DC000487.TIF
+ ;   i.e  487^C:\IMAGE\^DC000487.TIF
  ;  The calling routine is responsible for renaming/naming the file
  ;   to the returned DRIVE:\DIR\FILENAME.EXT
  ;
- ; Modified 4/23/98 to include hierarchical directory structure -- PMK
- I 'MAGGRP D
- . S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF)
- . ; For now, BIG files are in same directory as FullRes (or PACS) file
- . S MAGRY(0)=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM
- . ; If BIG file also, add it's Drive, Hash, Filename to end of Return string.
- . I $G(MAGACT("BIG")) D
- . . S X=$P(MAGGFNM,".",1)_".BIG"
- . . S MAGRY(0)=MAGRY(0)_U_MAGGDRV_MAGDHASH_U_X
- . . Q
- . Q
+ ; Modified 4/23/98 to include hierarchial directory structure -- PMK
+ S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF)
+ ; For now, BIG files are in same directory as FullRes (or PACS) file
+ S MAGRY(0)=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM
+ ; If BIG file also, add it's Drive, Hash, Filename to end of Return string.
+ I $G(MAGACT("BIG")) D
+ . S X=$P(MAGGFNM,".",1)_".BIG"
+ . S MAGRY(0)=MAGRY(0)_U_MAGGDRV_MAGDHASH_U_X
  ;
 CLEAN ; Called as tag
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIA1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGSIA1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIA1.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGSIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 12/27/2000 10:49 ]
- ;;3.0;IMAGING;**7,8,85,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,85**;16-March-2007;;Build 1039
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIU2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGSIU2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIU2.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGSIU2 ;WOIFO/GEK - Utilities for Image Add/Modify ; [ 12/27/2000 10:49 ]
- ;;3.0;IMAGING;**7,8,85,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,85**;16-March-2007;;Build 1039
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIUI.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGSIUI.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIUI.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGSIUI ;WOIFO/GEK - Utilities for Image Import API
- ;;3.0;IMAGING;**7,8,48,20,85,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,48,20,85**;16-March-2007;;Build 1039
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIV.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGSIV.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIV.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGSIV ;WOIFO/GEK - Imaging RPC Broker calls. Validate Image data array ; [ 12/27/2000 10:49 ]
- ;;3.0;IMAGING;**7,8,20,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIV1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGSIV1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGSIV1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGSIV1 ;WOIFO/GEK - Imaging Validate Data ; [ 08/15/2004 08:57 ]
- ;;3.0;IMAGING;**8,20,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTAU.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTAU.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTAU.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTAU ;WOIFO/GEK - RPC Calls to Update the Imaging Windows Workstation file ; [ 03/25/2001 11:20 ]
- ;;3.0;IMAGING;**7,16,8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,16,8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -18,16 +17,16 @@
  ;;
  Q
-UPD(MAGRY,DATA) ;RPC [MAGG WRKS UPDATES]
- ; Called after User login. Local and RIV.
- ; Updates information in the IMAGING WINDOWS WORKSTATION
+UPD(MAGRY,DATA) ;RPC [MAGG WRKS UPDATES] 
+ ; Call from workstation updating it's exe's Date/Time
+ ; and other Workstation information into IMAGING WINDOWS WORKSTATION
+ ; at logon of user.
  ;
  ; DATA is '^' delimited piece
  ; 1 Workstation name            2 Date/Time of capture app.
  ; 3 Date/Time of Display App.
- ; 4 Location of workstation      5 Date/Time of MAGSETUP
+ ; 4 Location of worksation      5 Date/Time of MAGSETUP
  ; 6 Version of Display          7 Version of Capture
  ; 8  1=Normal startup 2=Started by CPRS 3=Import API
  ; 9 OS Version                 10 VistaRad Version
- ; 11 RPCBroker Server    12 RPCBroker Port
  N X,Y,Z
  N MAGNAME,MAGCDT,MAGDDT,MAG0,MAGLOC,MAGIEN,MAGSETUP,MAGSTART,MAGSRV
@@ -40,12 +39,8 @@
  S MAGSETUP=$P(DATA,U,5)
  S MAGVERSD=$P(DATA,U,6)
- I MAGVERSD S MAGJOB("DISPLAY")=""
  S MAGVERSC=$P(DATA,U,7)
- I MAGVERSC S MAGJOB("CAPTURE")=""
  S MAGMODE=$P(DATA,U,8)
  S MAGOSVER=$P(DATA,U,9)
  S MAGVERVR=$P(DATA,U,10)
- I $P(DATA,U,11)]"" S MAGJOB("RPCSERVER")=$P(DATA,U,11)
- I $P(DATA,U,12)]"" S MAGJOB("RPCPORT")=$P(DATA,U,12)
  S MAGIEN=0
  I $L(MAGNAME) S MAGIEN=$O(^MAG(2006.81,"B",MAGNAME,""))
@@ -59,5 +54,5 @@
  L +^MAG(2006.81,"LOCK",MAGIEN):0
  S MAGIEN=+MAGIEN_","
- S MAGGFDA(2006.81,MAGIEN,.01)=MAGNAME ; Computer Name
+ S MAGGFDA(2006.81,MAGIEN,.01)=MAGNAME ; Compter Name
  I MAGCDT>-1 S MAGGFDA(2006.81,MAGIEN,4)=MAGCDT ;TELE19N.EXE dttm
  I MAGDDT>-1 S MAGGFDA(2006.81,MAGIEN,5)=MAGDDT ;IMGVWP10.EXE dttm
@@ -65,5 +60,5 @@
  S MAGGFDA(2006.81,MAGIEN,8)=1 ; Active or not.
  S MAGGFDA(2006.81,MAGIEN,6)=MAGLOC ; location free text from .INI
- S MAGGFDA(2006.81,MAGIEN,3)="@" ; delete logoff time for this job.
+ S MAGGFDA(2006.81,MAGIEN,3)="@" ; delete logff time for this job.
  S MAGGFDA(2006.81,MAGIEN,10)="@" ; delete session pointer
  S MAGGFDA(2006.81,MAGIEN,11)="@" ; reset the session error count.
@@ -75,5 +70,5 @@
  S X=$P(MAG0,U,12)
  S MAGGFDA(2006.81,MAGIEN,12)=X+1 ; Sess count for wrks.
- ; Keep PLACE that this wrks logged in.
+ ; Keep the last PLACE that this wrks logged in.
  S MAGPL=0 I $D(DUZ(2)) S MAGPL=+$$PLACE^MAGBAPI(DUZ(2)) ; DBI
  I MAGPL S MAGGFDA(2006.81,MAGIEN,.04)=MAGPL ; DBI
@@ -87,8 +82,9 @@
  D UPDATE^DIE("S","MAGGFDA","MAGXIEN","MAGXERR")
  I $D(DIERR) D RTRNERR(.MAGRY) Q
- ; The MAGJOB( array is used by Imaging routines that are
+ ; The " MAGJOB(" array is used by Imaging routines that are
  ; called from the Delphi App. 
+ ; We use nodes of the Array MAGJ0B to organize the shared partition variables.
  ; 
- ; 3.0.8 Whatever App calls this, we'll use that Version number.
+ ; 3.O.8 Whatever App calls this, we'll use that Version number.
  S MAGVERX=$S(MAGVERSD]"":MAGVERSD,MAGVERSC]"":MAGVERSC,MAGVERVR]"":MAGVERVR,1:0)
  S MAGJOB("WRKSIEN")=+MAGIEN
@@ -96,5 +92,5 @@
  S MAGRY="1^"
  ;
- ; SESSION : Create new session entry
+ ; SESSION : Now we create new session entry
  D GETS^DIQ(200,DUZ_",","29","I","Z","") ; service/section
  S MAGSRV=$G(Z(200,DUZ_",",29,"I"))
@@ -158,5 +154,5 @@
  ; $P(9) is Vrad REMOTE Read flag (1/0; 1=REMOTE)
  ; $P(TXT,"$$",2) is Tracking ID from an Imported Image.  From this we compute Session #, to log actions.
- ; LOGTM   - [1|0] Flag to indicate whether or not to log the time of the Action.  Default = 0
+ ; LOGTM   - [1|0] Flag to indicate wheter or not to log the time of the Action.  Default = 0
  ; MAGSESS - Session IEN where the action should be logged.  Default to MAGJOB("SESSION")
  ;
@@ -202,4 +198,5 @@
  ;   and marks the session closed.
  ;
+ K ^TMP("MAGGTAU","LOGOFF",$J)
  S MAGRY=1
  N MAGGFDA,MAGXERR,MAGXIEN,MAGIEN,MAGSESS,MAGEND,MAGCON
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTERR.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTERR.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTERR.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTERR ;WOIFO/GEK - IMAGING ERROR TRAP, AND ERROR LOG ; [ 06/20/2001 08:56 ]
- ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -21,5 +20,6 @@
  ;  This will enable logging Imaging errors and Sending messages for
  ;  certain errors etc. later
- ;N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
+ ;IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
+ ;E  S X="ERRA^MAGGTERR",@^%ZOSF("TRAP")
  ;
  ; This assumes the Return variable or array is MAGRY or MAGRY()
@@ -46,17 +46,12 @@
 LOGERR(ERROR) ;
  Q:'$G(MAGJOB("SESSION"))
- N SESS,WRKS,ERR
- S SESS=$G(MAGJOB("SESSION"))
- ; Quit if No entry in Session File.
- Q:'$D(^MAG(2006.82,SESS,0))
- I '$D(^MAG(2006.82,SESS,"ERR",0)) S ^MAG(2006.82,SESS,"ERR",0)="^2006.823A^0^0"
- S ERR=$O(^MAG(2006.82,SESS,"ERR"," "),-1)+1
- S ^MAG(2006.82,SESS,"ERR",ERR,0)=ERROR
- S $P(^MAG(2006.82,SESS,"ERR",0),"^",3,4)=ERR_"^"_ERR
- ;
- Q:'$G(MAGJOB("WRKSIEN"))
- S WRKS=$G(MAGJOB("WRKSIEN"))
- ; Quit if No entry in Workstation File.
- Q:'$D(^MAG(2006.81,WRKS,0))
- S $P(^MAG(2006.81,WRKS,0),"^",11)=ERR
+ N MAGGFDA,MAGXERR,MAGXIEN,MAGNODE
+ S MAGNODE="+1,"_+MAGJOB("SESSION")_","
+ ;S MAGNODE="+1,10,"
+ S MAGGFDA(2006.823,MAGNODE,.01)=ERROR
+ D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR")
+ ; error flag for this session in workstation file
+ S MAGNODE=+MAGJOB("WRKSIEN")_","
+ S MAGGFDA(2006.81,MAGNODE,11)=+MAGXIEN(1) ;
+ D UPDATE^DIE("","MAGGFDA","MAGXIEN","MAGXERR")
  Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTIA1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTIA1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTIA1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTIA1 ;WOIFO/GEK - RPC Call to Add Image File entry ; [ 06/20/2001 08:56 ]
- ;;3.0;IMAGING;**21,8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**21,8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -33,6 +32,6 @@
  . D ACTION^MAGGTAU("MOD^"_$P(^MAG(2005,+MAGMOD,0),U,7)_"^"_+$G(MAGMOD)) ; This is the Image IEN
  ;
- ; There are incidents of using an IEN from a deleted image
- ;  these next lines are to stop the problem.
+ ; There are incidents of using an IEN from a deleted image (still)
+ ;  these next lines are TESTING for now.  To stop the problem.
  S GIEN=$O(^MAG(2005," "),-1)+1
  S DIEN=$O(^MAG(2005.1," "),-1)+1
@@ -56,12 +55,13 @@
  ;   we Return the IEN with NO Filename. Groups don't get Filename
  ;
- I MAGGR S MAGRY=MAGGDA_U,Z="" D  G C1
+ I MAGGR S MAGRY=MAGGDA_U,Z="" D  Q
  . F  S Z=$O(MAGGR(Z)) Q:Z=""  S $P(^MAG(2005,Z,0),U,10)=MAGGDA
  . D CLEAN
  ;
  S X=$G(MAGGFDA(2005,"+1,",14)) I +X D
- . ; If here: This image is a member of a Group
- . ;   -Modify the Group Parent, add DA to it's group
- . ;   -Also set 'Series Number' and 'Image Number' if they exist;
+ . ; We're here beceause this image is a member of a Group
+ . ;   so we will modify the Group Parent, adding this to it's group
+ . ; HERE we will also send the 'Series Number' and 'Image Number' if
+ . ; they exist;
  . K MAGGFDA
  . S Y="+2,"_X_","
@@ -72,6 +72,8 @@
  . D UPDATE^DIE("S","MAGGFDA","MAGGIEN","MAGGXE")
  ;
- ; Now get the Image file name. DOS FILE name
- ; The ENTRY in Image File has been made, if any errors from here on
+ ;
+ ;
+ ; now get the Image file name. DOS FILE name
+ ; ENTRY in Image File has been made, if any errors from here on
  ;  then we have to delete the image entry.
  I $D(MAGGFDA(2005,"+1,",1)) S MAGGFNM=MAGGFDA(2005,"+1,",1) G C1
@@ -93,33 +95,14 @@
  ;
 C1 ; we jump here if we already had a Filename sent
+ ;
  K MAGGFDA
  ; New Index Field Check.  If this entry doesn't have the Index fields introduced
  ;   in 3.0.8 then we use the Patch 17 conversion API call to generate default values.
  ;
- ;P59 Now we Auto-Generate the Index Fields, if they don't exist for this entry.
- I '$D(^MAG(2005,MAGGDA,40)) D
- . N INDXD
- . D GENIEN^MAGXCVI(MAGGDA,.INDXD)
- . S ^MAG(2005,MAGGDA,40)=INDXD
- . S ^MAGIXCVT(2006.96,MAGGDA)=2 ; Flag. Says fields were converted Patch 59
- . ; TRKING ID  TRKID =   MAGGFDA(2005,"+1,",108)
- . D ACTION^MAGGTAU("INDEX-ALL^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108))
- . D ENTRY^MAGLOG("INDEX-ALL",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1)
- . Q
- ;P59 If TYPE INDEX is missing we Auto-Generate Index Type and other missing Index Term values.
- I '$P(^MAG(2005,MAGGDA,40),"^",3) D
- . N INDXD,OLD40,N40
- . S (N40,OLD40)=^MAG(2005,MAGGDA,40)
- . D GENIEN^MAGXCVI(MAGGDA,.INDXD)
- . ; If Origin doesn't exist in existing, this will put V in. 
- . I $P(INDXD,"^",6)="" S $P(INDXD,"^",6)="V"
- . ; We're not changing existing values of Spec,Proc or Origin 
- . F J=1:1:6 I '$L($P(N40,"^",J)) S $P(N40,"^",J)=$P(INDXD,"^",J)
- . ;Validate the merged Spec and Proc, if  not valid, revert back to old Spec and Proc
- . I '$$VALINDEX^MAGGSIV1(.X,$P(N40,"^",3),$P(N40,"^",5),$P(N40,"^",4)) S $P(N40,"^",4,5)=$P(OLD40,"^",4,5)
- . S ^MAG(2005,MAGGDA,40)=N40
- . D ACTION^MAGGTAU("INDEX-42^"_$P(^MAG(2005,MAGGDA,0),"^",7)_"^"_MAGGDA) ;_"$$"_MAGGFDA(2005,"+1,",108))
- . D ENTRY^MAGLOG("INDEX-42",DUZ,MAGGDA,"P59",$P(^MAG(2005,MAGGDA,0),"^",7),1)
- . Q
+ ;-This is being deferred to a later patch.
+ ;-I '$D(^MAG(2005,MAGGDA,40)) D
+ ;-. D ONE^MAGSCNVI(MAGGDA)
+ ;-. D ACTION^MAGGTAU("DFTINDX^^"_MAGGDA)
+ ;
  ;** ABS and JB image queues AREN'T SET WHEN ADDING AN IMAGE. 
  ;** IT IS DONE IN A SEPERATE CALL 
@@ -136,17 +119,15 @@
  ; 
  ;  We return the IEN ^ DRIVE:DIR ^ FILE.EXT
- ;   example:   487^C:\IMAGE\^DC000487.TIF
+ ;   i.e  487^C:\IMAGE\^DC000487.TIF
  ;  The calling routine is responsible for renaming/naming the file
  ;   to the returned DRIVE:\DIR\FILENAME.EXT
- ;  4/23/98 to include hierarchical directory structure -- PMK
+ ;  Modified 4/23/98 to include hierarchial directory structure -- PMK
  ;
- I 'MAGGR D
- . S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF)
- . S MAGRY=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM
- . ; For now, BIG files are in same directory as FullRes (or PACS) file
- . I $G(MAGBIG) D
- . . S X=$P(MAGGFNM,".",1)_".BIG"
- . . S MAGRY=MAGRY_U_MAGGDRV_MAGDHASH_U_X
- . . Q
+ S MAGDHASH=$$DIRHASH^MAGFILEB(MAGGFNM,MAGREF)
+ S MAGRY=MAGGDA_U_MAGGDRV_MAGDHASH_U_MAGGFNM
+ ; For now, BIG files are in same directory as FullRes (or PACS) file
+ I $G(MAGBIG) D
+ . S X=$P(MAGGFNM,".",1)_".BIG"
+ . S MAGRY=MAGRY_U_MAGGDRV_MAGDHASH_U_X
  . Q
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTID.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTID.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTID.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTID ;WOIFO/SRR/RED/SAF/GEK - Deletion of Images and Pointers ; [ 06/20/2001 08:56 ]
- ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -20,9 +19,7 @@
  ;
 IMAGEDEL(MAGGRY,MAGIEN,MAGGRPDF,REASON) ;RPC [MAGG IMAGE DELETE]
- ; Call to Delete Image entry from Image file ^MAG(2005
- ; MAGIEN   Image IEN ^ SYSDEL flag
- ; MAGGRPDF   group delete flag   1 = group delete allowed
- ; SYSDEL    Flag that forces delete, even if no KEY
- ; 
+ ; Call to Delete Image entry 
+ ; SEB 6/6/2002 - added MAGGRPDF - group delete flag = 1 if group delete allowed
+ ; from Image file ^MAG(2005
  N Y,RY
  ; 1 in 3rd piece means : DELETE the Image File Also.
@@ -135,8 +132,6 @@
  Q
 SETDEL(MAGIEN,REASON) ; set deletion fields
- N DA,DR,DIE,X
- ;N %H
- ;S %H=$H D YMD^%DTC
- S X=$$NOW^XLFDT
+ N DA,DR,DIE,%H,X
+ S %H=$H D YMD^%DTC
  ;  gek - changed 3 slash to 4 slash. to stop FM question marks. ??
  S DR="30////"_DUZ_";30.1////"_X_";30.2////"_REASON
@@ -145,5 +140,5 @@
  ;
 ARCHIVE(MAGARCIE) ;save image data before deletion
- N MAGCNT,MAGLAST,%X,%Y
+ N MAGCNT,MAGLAST
  S MAGCNT=$P(^MAG(2005.1,0),U,4)+1
  S %X="^MAG(2005,"_MAGARCIE_",",%Y="^MAG(2005.1,"_MAGARCIE_","
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTII.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTII.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTII.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTII ;WOIFO/GEK - RETURN IMAGE INFO ; [ 11/08/2001 17:18 ]
- ;;3.0;IMAGING;**8,48,63,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8,48,63**;Apr 11, 2005
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -40,19 +40,15 @@
  ; $P(19^20)   Patient DFN  ^ Patient Name; // Patch 3.8
  ; $P(21)          Image Class: Clin,Admin,Clin/Admin,Admin/Clin
- ; $p(22)      Date Time Image Saved(FLD 7)
- ; $p(23)      Document Date    (FLD 110)
  ;
  N FILETYPE,MAGPREF,MAGJBCP,GRPTYPE,GRPIEN,ABSTYPE,MAGTYPE,MAGJBOL
  N MAGOFFLN,FULLTYPE,MAGOBJT,MAGQI,X
  N ABSFILE,FULLFILE,BIGFILE,PATCH,MDFN,FNL,PLC,PLCODE
- N MAGN0,MAGN2,MAGN40,MAGN100
+ N MAGN0,MAGN2,MAGN40
  ;    set the Variables for the Global Nodes of the Image Entry
- S MAGN0=$G(^MAG(2005,MAGXX,0))
- S MDFN=$P(MAGN0,"^",7)
+ S MAGN0=$G(^MAG(2005,MAGXX,0)),MDFN=$P(MAGN0,"^",7) ; P48T1 MDFN
  S MAGN2=$G(^MAG(2005,MAGXX,2))
  S MAGN40=$G(^MAG(2005,MAGXX,40))
- S MAGN100=$G(^MAG(2005,MAGXX,100))
- ; Set Name in Variable, Call $$GET 1 time not 2000
- I MDFN I '$D(MAGJOB("PTNM",MDFN)) S MAGJOB("PTNM",MDFN)=$$GET1^DIQ(2,MDFN_",",.01)
+ ; P48T1 Set Name in Variable, Call $$GET 1 time not 2000
+ I '$D(MAGJOB("PTNM",MDFN)) S MAGJOB("PTNM",MDFN)=$$GET1^DIQ(2,MDFN_",",.01)
  I '$D(MAGJOB("NETPLC")) D NETPLCS^MAGGTU6
  ;  Object Type
@@ -119,5 +115,4 @@
  S PLC=$P($G(MAGJOB("NETPLC",FNL)),"^",1)
  S PLCODE=$P($G(MAGJOB("NETPLC",FNL)),"^",2)
- I PLC="" S PLC=$G(MAGJOB("PLC")),PLCODE=$G(MAGJOB("PLCODE")) ; Group of 0 need this.
  ;   if we were using first image of a group, reset the Real IEN 
  I $G(GRPIEN) S MAGXX=GRPIEN
@@ -135,9 +130,8 @@
  K MAGFILE
  S $P(MAGFILE,U,25)="" ; We put extra '^^^' on end of String to stop error in Delphi.
- ; Pieces 26 BrokerServer and 27 Broker Port are set if this is P59 Client.
- ; Clients Prior to Patch 59, the String must only be 25 pieces. - Patch 45 snafu
- ; 
+ ;
  ; $P(1^2^3) IEN^Image FullPath and name^Abstract FullPath and Name 
  S $P(MAGFILE,U,1,3)=MAGXX_U_FULLFILE_U_ABSFILE
+ S $P(MAGFILE,U,18)=BIGFILE
  ;
  ; now set $P(4) SHORT DESCRIPTION field and desc of offline JukeBox
@@ -156,6 +150,6 @@
  ;  the delphi TStringGrid so we display mm/dd/yyyy
  ; now set $P(8) display date
- S X=$$FMTE^XLFDT($P(MAGN2,U,5),"5Z")
- S X=$TR(X,"@"," ")
+ S X=$P($P(MAGN2,"^",5),".",1)
+ I X'="" S X=$E(X,4,5)_"/"_$E(X,6,7)_"/"_($E(X,1,3)+1700)
  S $P(MAGFILE,U,8)=X
  ;
@@ -174,5 +168,5 @@
  ;    $p(12) and $p(13)
  ;
- ; 14 - count of images , if this is a group
+ ; lets add the count of images , if this is a group
  S X=+$P($G(^MAG(2005,MAGXX,1,0)),U,4),$P(MAGFILE,U,14)=$S(X:X,1:1)
  ;
@@ -191,23 +185,13 @@
  . ;Send the error message
  . S $P(MAGFILE,U,17)=$P(MAGQI(0),U,2)
- ; $p(18) is BIGFile Full name and path.
- S $P(MAGFILE,U,18)=BIGFILE
- ; DFN
- S $P(MAGFILE,U,19)=$P(MAGN0,U,7)
- ; Patient Name
- S $P(MAGFILE,U,20)=$S(MDFN:MAGJOB("PTNM",MDFN),1:MDFN)
+ ; $p(18) is BIGFile Full name and path. ( set above)
+ ; Patches prior to 8, only had 17 pieces of data. this will speed up their listings.
+ ; Patch 8 had New M rtn MAGSIXG1, if it doesn't exist, this is PRE - 8.
+ I '$L($T(PGI^MAGSIXG1)) Q
+ S $P(MAGFILE,U,19)=$P(MAGN0,U,7)                         ; DFN
+ ; P48T1 The change to speed up access to large groups left out patient name.
+ ;S $P(MAGFILE,U,20)=$$GET1^DIQ(2,$P(MAGN0,U,7)_",",.01)   ; Patient Name
+ S $P(MAGFILE,U,20)=MAGJOB("PTNM",MDFN)
  S $P(MAGFILE,U,21)=$S(+$P(MAGN40,U,2):$P(^MAG(2005.82,$P(MAGN40,U,2),0),U),1:"")
- S X=$$FMTE^XLFDT($P(MAGN2,U,1),"5Z") ; Date/Time Image Saved  #7
- S X=$TR(X,"@"," ")
- S $P(MAGFILE,U,22)=X
- S X=$$FMTE^XLFDT($P(MAGN100,U,6),"5Z")   ; DocumentDate #110
- S X=$TR(X,"@"," ")
- S $P(MAGFILE,U,23)=X
- ; If Patch 59 Client - we can set beyond 25 pieces.
- I $D(MAGJOB("RPCSERVER"))&$D(MAGJOB("RPCPORT")) D
- . S $P(MAGFILE,U,26)=MAGJOB("RPCSERVER")
- . S $P(MAGFILE,U,27)=MAGJOB("RPCPORT")
- . S $P(MAGFILE,U,28)="" ; "^" at end, stops problems in delphi
- . Q
  ; Stop displaying a Group of 1 as a Group, so here we'll change Object type
  ;  to that of the '1ST' image in the group of 1.
@@ -217,4 +201,4 @@
  . S $P(MAGFILE,U,6)=$P(^MAG(2005,X,0),U,6) ; OBJECT TYPE OF 1ST IMAGE IN GROUP
  . S $P(MAGFILE,U,1)=X
- . Q
+ . ; Need Site and Site code of 
  Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTLB1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTLB1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTLB1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTLB1 ;WOIFO/LB - RPC routine for Imaging Lab Interface ; [ 06/20/2001 08:56 ]
- ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;;Mar 01, 2002
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -118,4 +118,3 @@
  I $D(DIERR) S MAGRY="0^Unsuccessful both files not updated." K DIERR Q
  S MAGRY="1^Success in filing both parent & image files." K DIERR
- D LINKDT^MAGGTU6(.X,+MAGIEN)
  Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTMC1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTMC1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTMC1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTMC1 ;WOIFO/GEK - RPC Calls for Imaging/Medicine procedures ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;;Mar 01, 2002
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -28,5 +27,5 @@
  IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR"
  E  S X="ERR^MAGGTERR",@^%ZOSF("TRAP")
- N I,J,K,X,Y,Z,TIME,PSIEN,DFN,MAGPTR,MAGMCIEN,MCFILE,MAGOK,MAGERR,PROCSTUB
+ N I,J,K,X,Y,Z,TIME,PSIEN,DFN,MAGPTR,MAGMCIEN,MCFILE,MAGOK,MAGERR
  ;
  S X=$P(DATA,U,1),%DT="TS" D ^%DT S TIME=Y
@@ -55,5 +54,4 @@
  S I="" F  S I=$O(MAGPTR(I)) Q:I=""  D
  . S $P(^MAG(2005,I,2),U,6,8)=MAGPTR(I)
- . D LINKDT^MAGGTU6(.X,I)
  S MAGRY=MAGOK
  Q
@@ -64,5 +62,5 @@
  ;  DATA is    null  ^ PSIEN ^ DFN ^ MCIEN ^ null
  ; 
- N TMCFILE,TPSIEN,TDFN,TMCIEN,RETX
+ N TMCFILE,TPSIEN,TDFN,TMCIEN
  S TPSIEN=+$P(DATA,U,2)
  S TDFN=+$P(DATA,U,3)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTPT1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTPT1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTPT1.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGGTPT1 ;WOIFO/GEK - Delphi-Broker calls for patient lookup and information ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**16,8,92,46,59**;Nov 27, 2007;Build 20
+ ;;3.0;IMAGING;**16,8,92**;Jan 10, 2007;Build 1
  ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -23,5 +23,5 @@
  ; MAGRY is the Array to return.
  ; ZY is parameter sent by calling app (Delphi)
- ;    FILE NUM ^ NUM TO RETURN ^ TEXT TO MATCH ^  ^ SCREEN ($P 5-99)
+ ;     NUM TO RETURN ^ TEXT TO MATCH ^  ^ ^ SCREEN ($P 5-99)
  N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTRA.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTRA.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTRA.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTRA ;WOIFO/GEK - RPC Call to list Patient's Rad/Nuc Exams, Reports ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;;Mar 01, 2002
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -40,6 +40,6 @@
  ;  MAGIEN is Image File IEN ^MAG(2005,IEN
  ;
- N Y,I,CT,MAGERR,DIQUIET
- N RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST,MAGGP
+ N Y,I,CT,MAGERR
+ N RADFN,RADTI,RACNI,RANME,RASSN,RADATE,RADTE,RACN,RAPRC,RARPT,RAST
  IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGGTERR"
  E  S X="ERR^MAGGTERR",@^%ZOSF("TRAP")
@@ -72,4 +72,3 @@
  ; DONE.
  S MAGRY="1^Image pointer filed successfully"
- D LINKDT^MAGGTU6(.X,MAGIEN)
  Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSR.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTSR.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSR.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTSR ;WOIFO/GEK - SURGERY CASE LIST ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -18,60 +17,25 @@
  ;;
  Q
-GET(MAGRY,MAGDFN,DATA) ;RPC [MAGGSUR GET]
+GET(MAGRY,MAGDFN) ;RPC [MAGGSUR GET]
  ; Call to get list of Patient Surgery procedures
- ;  MAGDFN       =       Patient DFN
- ;  DATA         =       For Future Use.
- N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
- N Y,NAME,AI,CASES,SDAT,DTX,SRFDA
- K ^TMP($J,"MAGGTSR")
- S NAME=$P($G(^DPT(MAGDFN,0)),U) I NAME="" S MAGRY(0)="0^INVALID Patient ID" Q
- ; This is the Old Call we have always made.  Doesn't have Non-OR
+ ; MAGDFN is Patient DFN
+ ;
+ IF $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERRA^MAGGTERR"
+ E  S X="ERRA^MAGGTERR",@^%ZOSF("TRAP")
+ N Y,DFN,MAGNAME
+ S MAGNAME=$P($G(^DPT(MAGDFN,0)),U)
+ I MAGNAME="" S MAGGRY(0)="0^INVALID Patient ID" Q
  D GET^SROGTSR(.MAGRY,MAGDFN)
- I 'MAGRY(0) S MAGRY(0)=MAGRY(0)_" for "_NAME G C1
- ; Image count is for future use by Display
- S MAGRY(1)="#^Date^Case description^Case #^Images"
+ I 'MAGRY(0) S MAGRY(0)=MAGRY(0)_" for "_MAGNAME Q
+ ; Here we are changing the data returned in the array, from SROGTSR
+ ; , it will now also return the count of images associated with the 
+ ; surgery report.  This is in advance of the change for Display, to 
+ ; list the patient's surgery reports, like we list radiology reports.
+ ;
+ I (+$G(MAGJOB("VERSION"))<2.5) Q
+ S MAGRY(1)=$P(MAGRY(1),U,1,3)_"^Images"
  S I=1 F  S I=$O(MAGRY(I)) Q:'I  D
- . S DTX=$$FMTE^XLFDT($P(MAGRY(I),U,5),"5MZ")
- . S ^TMP($J,"MAGGTSR",$P(MAGRY(I),U,5),$P(MAGRY(I),U,4))=DTX_"^"_$P(MAGRY(I),U,3)_"^"_$P(MAGRY(I),"^",4)_"^"_$P(MAGRY(I),U,6)_U_"|"_$P(MAGRY(I),U,4,5)_U
- ;
- ;This is the New Call, which has Non-OR, but doesn't have (Scheduled) so we merge the two calls.
-C1 D LIST^SROESTV(.CASES,MAGDFN)
- I '$D(@CASES)  G E1
- S MAGRY(0)="1^"
- S MAGRY(1)="#^Date^Case description^Case #^Images"
- S I=0 F  S I=$O(@CASES@(I)) Q:'I  D
- . S SDAT=@CASES@(I)
- . ; SDAT = SURIEN  ^ SURDESC  ^ SURDT ^ DFN;NAME ^ 
- . I $D(^TMP($J,"MAGGTSR",$P(SDAT,U,3),$P(SDAT,U,1))) Q
- . S ^TMP($J,"MAGGTSR",$P(SDAT,U,3),$P(SDAT,U,1))=$$FMTE^XLFDT($P(SDAT,U,3),"5MZ")_U_$P(SDAT,U,2)_U_$P(SDAT,U,1)_U_$$IMGCT($P(SDAT,U,1))_U_"|"_$P(SDAT,U,1)_U_$P(SDAT,U,3)_U
- . Q
- ;
- ; Now Returned the Merged List of the results of Old Call, with Results of New Call.
-E1 ;
- I '$D(^TMP($J,"MAGGTSR")) S MAGRY(0)="0^No Cases for "_$G(NAME) Q
- S I=1,DTX=0,SRFDA=0
- F  S DTX=$O(^TMP($J,"MAGGTSR",DTX)) Q:'DTX  D
- . S SRFDA="" F  S SRFDA=$O(^TMP($J,"MAGGTSR",DTX,SRFDA),-1) Q:'SRFDA  D
- . . S I=I+1,MAGRY(I)=I-1_"^"_^TMP($J,"MAGGTSR",DTX,SRFDA)
- . . Q
- . Q
- S $P(MAGRY(0),"^",1)=I-1
+ . S MAGRY(I)=$P(MAGRY(I),U,1,3)_U_$P(MAGRY(I),U,6)_U_$C(124)_$P(MAGRY(I),U,4,5)_U
  Q
-IMGCT(SRFIEN) ;
- ;  Count of images for this Surgery Case
- ;  If more than one group (or image) 
- ;  then return "Group count : total images"  i.e.   "3:134"
- ;  else return count of Images i.e. "4"
- ;
- N CT,GCT,ICT,J
- S J=0,CT=0,GCT=0
- F  S J=$O(^SRF(SRFIEN,2005,"B",J)) Q:'J  D
- . S ICT=+$P($G(^MAG(2005,J,1,0)),U,4)
- . S ICT=$S(ICT:ICT,1:1) ;If no group images, set count =1 (single image)
- . S GCT=GCT+1
- . S CT=CT+ICT
- I (GCT>1) Q GCT_":"_CT
- Q CT
- ;       
 IMAGE(MAGRY,DATA) ;
  ;  Called with the IEN of the Surgery package ^SRF(170,x
@@ -87,14 +51,14 @@
  ; We'll make a tmp list of just the image IEN's
  ;  splitting groups into individual image entries.
- K ^TMP($J,"MAGGX")
+ K ^TMP("MAGGX",$J)
  S I=0,CT=1 F  S I=$O(^SRF(SRFIEN,2005,I)) Q:'I  D
  . S MAGIEN=$P(^SRF(SRFIEN,2005,I,0),U,1)
  . Q:'$D(^MAG(2005,MAGIEN,0))
- . I '$O(^MAG(2005,MAGIEN,1,0)) S ^TMP($J,"MAGGX",MAGIEN)=""
- . E  S Z=0 F  S Z=$O(^MAG(2005,MAGIEN,1,Z)) Q:Z=""  S ^TMP($J,"MAGGX",$P(^MAG(2005,MAGIEN,1,Z,0),U,1))=""
- I '$D(^TMP($J,"MAGGX")) S MAGRY(0)="0^Surgery File Entry "_SRFIEN_": has INVALID Image Pointers" Q
+ . I '$O(^MAG(2005,MAGIEN,1,0)) S ^TMP("MAGGX",$J,MAGIEN)=""
+ . E  S Z=0 F  S Z=$O(^MAG(2005,MAGIEN,1,Z)) Q:Z=""  S ^TMP("MAGGX",$J,$P(^MAG(2005,MAGIEN,1,Z,0),U,1))=""
+ I '$D(^TMP("MAGGX",$J)) S MAGRY(0)="0^Surgery File Entry "_SRFIEN_": has INVALID Image Pointers" Q
  S Z="",CT=0
  S MAGQUIET=1
- F  S Z=$O(^TMP($J,"MAGGX",Z)) Q:Z=""  D
+ F  S Z=$O(^TMP("MAGGX",$J,Z)) Q:Z=""  D
  . S CT=CT+1,MAGXX=Z D INFO^MAGGTII
  . S MAGRY(CT)="B2^"_MAGFILE
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSR1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTSR1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSR1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTSR1 ;WOIFO/GEK - ADD IMAGES TO SURGERY FILE ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;;Mar 01, 2002
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -48,5 +47,4 @@
  S MAGRY="1^Image added to Surgery Package"
  S $P(^MAG(2005,MAGIEN,2),U,6,8)="130^"_MAGSIEN_U_MAGIENS(1)
- D LINKDT^MAGGTU6(.X,MAGIEN)
  Q
 RTRNERR(ETXT) ; There was error from UPDATE^DIE quit with error text
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSY2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTSY2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSY2.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTSY2 ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;;Mar 01, 2002
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -17,34 +17,14 @@
  ;;
  Q
-MAG(MAGRY,NODE) ;RPC Call to show node of Image File
- ;  NODE is the IEN of Image File :  ^MAG(2005,NODE
- N Y,I,CT,X,TNODE
+MAG(MAGRY,NODE) ; RPC Call for MAGSYS utility. Returns Global Node.
+ N CT,I,X,Y
  S MAGRY=$NA(^TMP("MAGNODE",$J))
- S NODE=$G(NODE)
- N I,CT,X
+ S NODE=+$G(NODE)
+ I 'NODE S NODE=$P(^MAG(2005,0),U,3)
  K @MAGRY
- S @MAGRY@(0)="Display NODE: "_$S($L(NODE):NODE,1:"LAST")
+ ;S @MAGRY@(0)="Display Imaging File NODE "_$S(NODE:NODE,1:"LAST")
  S I=0,CT=0
- I $E(NODE)="^" G OTH
- I 'NODE S NODE=$P(^MAG(2005,0),U,3)
  S I="^MAG(2005,"_NODE_","""")"
  F  S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE  D
  . S CT=CT+1,@MAGRY@(CT)=X_" "_@X
- . Q
- I $P($G(^MAG(2005,NODE,2)),"^",6)="8925" D
- . S CT=CT+1,@MAGRY@(CT)="   *******   TIU    ******* "
- . S TNODE=$P(^MAG(2005,NODE,2),"^",7)
- . S I="^TIU(8925,"_TNODE_","""")"
- . F  S X=$Q(@I) S I=X Q:$P(X,",",2)'=TNODE  D
- . . S CT=CT+1,@MAGRY@(CT)=X_" "_@X
- . . Q
  Q
-OTH ;
- N OTHDA
- S OTHDA=$P(NODE,",",2)
- I OTHDA=0 S NODE=NODE_")" Q:'$D(@NODE)  S CT=$O(@MAGRY@(""),-1)+1,@MAGRY@(CT)=$G(@(NODE)) Q
- S I=NODE_","""")"
- F  S X=$Q(@I) S I=X Q:$P(X,",",2)'=OTHDA  D
- . S CT=$O(@MAGRY@(""),-1)+1,@MAGRY@(CT)=X_" "_@X
- . Q
- Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSYS.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTSYS.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTSYS.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTSYS ;WOIFO/GEK - Calls from Imaging windows for System Manager ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;;Mar 01, 2002
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -17,50 +17,41 @@
  ;;
  Q
-GETS(MAGRY,NODE,FLAGS) ; USE GETS^DIQ TO GET FIELD VALUES.
- K MAGWIN,I,CT,Y,NC,MAGOUT,MAGERR,TNC,ZZ
+MAG(MAGRY,NODE) ;RPC Call to show node of Image File
+ ;  NODE is the IEN of Image File :  ^MAG(2005,NODE
+ N Y
  S MAGRY=$NA(^TMP("MAGNODE",$J))
  S NODE=+$G(NODE)
  I 'NODE S NODE=$P(^MAG(2005,0),U,3)
+ N MAGWIN,I,CT,X
  S MAGWIN=$$BROKER^XWBLIB
+ K @MAGRY
+ ;S @MAGRY@(0)="Display Imaging File NODE "_$S(NODE:NODE,1:"LAST")
+ S I=0,CT=0
  I 'MAGWIN W !,"NODE","  ",NODE
+ S I="^MAG(2005,"_NODE_","""")"
+ F  S X=$Q(@I) S I=X Q:$P(X,",",2)'=NODE  D
+ . S CT=CT+1,@MAGRY@(CT)=X_" "_@X
+ . I 'MAGWIN W !,X," ",@X
+ ;
+ Q
+GETS(MAGRY,NODE,FLAGS) ; USE GETS^DIQ TO GET FIELD VALUES.
+ N Y
+ S MAGRY=$NA(^TMP("MAGNODE",$J))
+ S NODE=+$G(NODE)
+ I 'NODE S NODE=$P(^MAG(2005,0),U,3)
+ N MAGWIN,I,CT
+ S MAGWIN=$$BROKER^XWBLIB
  K @MAGRY
- S @MAGRY@(0)="******    Fields for Image IEN: "_NODE_"    ******"
+ S @MAGRY@(0)="Fields for Image IEN: "_NODE
  S I=0,CT=0
+ I 'MAGWIN W !,"NODE","  ",NODE
+ N MAGOUT,MAGERR
  S FLAGS=$S($L($G(FLAGS)):FLAGS,1:"IERN")
  D GETS^DIQ(2005,NODE,"*",FLAGS,"MAGOUT","MAGERR")
  ;D GETS^DIQ(2005,NODE,".01;1;2;2.1;2.2;3;5;6;12","R","MAGOUT","MAGERR")
- S NC=NODE_","
- S I="" F  S I=$O(MAGOUT(2005,NC,I)) Q:I=""  D
+ S NNODE=NODE_","
+ S I="" F  S I=$O(MAGOUT(2005,NNODE,I)) Q:I=""  D
  . S CT=CT+1
- . I $G(MAGOUT(2005,NC,I,"I"))=$G(MAGOUT(2005,NC,I,"E")) D  Q
- . . S ZZ=I,$E(ZZ,45,999)=" = "_$G(MAGOUT(2005,NC,I,"E"))
- . . S @MAGRY@(CT)=ZZ
- . . ;S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NC,I,"E") Q
- . . Q
- . ;
- . S ZZ=I,$E(ZZ,25,999)=" = ("_$G(MAGOUT(2005,NC,I,"I"))_") "
- . I ($L(ZZ)>44) S ZZ=ZZ_" = "_$G(MAGOUT(2005,NC,I,"E")) S @MAGRY@(CT)=ZZ Q
- . I ($L(ZZ)<45) S $E(ZZ,45,999)=" = "_$G(MAGOUT(2005,NC,I,"E")) S @MAGRY@(CT)=ZZ Q
- . ;S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NC,I,"I"))_") = "_$G(MAGOUT(2005,NC,I,"E"))
- . Q
- I $P($G(^MAG(2005,NODE,2)),"^",6)=8925 D
- . K MAGOUT,MAGERR
- . S CT=CT+1,@MAGRY@(CT)="   ***************   TIU    *************** "
- . S CT=CT+1,@MAGRY@(CT)="   **** Field Values for TIUDA: "_$P(^MAG(2005,NODE,2),"^",7)_"  ****"
- . D GETS^DIQ(8925,$P(^MAG(2005,NODE,2),"^",7),"*",FLAGS,"MAGOUT","MAGERR")
- . S NC=$P(^MAG(2005,NODE,2),"^",7)_","
- . S I="" F  S I=$O(MAGOUT(8925,NC,I)) Q:I=""  D
- . . S CT=CT+1
- . . I $G(MAGOUT(8925,NC,I,"I"))=$G(MAGOUT(8925,NC,I,"E")) D  Q
- . . . S ZZ=I,$E(ZZ,45,999)=" = "_$G(MAGOUT(8925,NC,I,"E"))
- . . . S @MAGRY@(CT)=ZZ
- . . . ;S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NC,I,"E") Q
- . . . Q
- . . ;
- . . S ZZ=I,$E(ZZ,25,999)=" = ("_$G(MAGOUT(8925,NC,I,"I"))_") "
- . . I ($L(ZZ)>44) S ZZ=ZZ_" = "_$G(MAGOUT(8925,NC,I,"E")) S @MAGRY@(CT)=ZZ Q
- . . I ($L(ZZ)<45) S $E(ZZ,45,999)=" = "_$G(MAGOUT(8925,NC,I,"E")) S @MAGRY@(CT)=ZZ Q
- . . ;S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NC,I,"I"))_") = "_$G(MAGOUT(2005,NC,I,"E"))
- . . Q
- . Q
+ . I $G(MAGOUT(2005,NNODE,I,"I"))=$G(MAGOUT(2005,NNODE,I,"E")) S @MAGRY@(CT)=I_" = "_MAGOUT(2005,NNODE,I,"E") Q
+ . S @MAGRY@(CT)=I_" = ("_$G(MAGOUT(2005,NNODE,I,"I"))_") = "_$G(MAGOUT(2005,NNODE,I,"E"))
  Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU1.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGTU1 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**3,8,85,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**3,8,85**;16-March-2007;;Build 1039
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU3.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU3.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU3.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGTU3 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**7,8,48,45,20,46,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,48,45,20,46**;16-February-2007;;Build 1023
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -18,6 +18,6 @@
  Q
 IMAGEINF(MAGRY,IEN,NOCHK) ;RPC [MAGG IMAGE INFO] Call to return information for 1 image;
- ; IEN   =       Image IEN  ^MAG(2005,IEN
- ; NOCHK =    1|""   if 1 then do not run QA check on this image.
+ ; IEN   =       Image IEN ^MAG(2005,IEN
+ ; NOCHK =   If Flag = 1, then do not run QA check on this image.
  ; 
  N MAGFILE,Y,Z,MAGNOCHK
@@ -66,10 +66,10 @@
  ; NOW NET STUFF
  I 'MAGPLC Q 
- ; From IMAGING SITE PARAMETERS File
- ;   get the Network UserName and PassWord.
+ ; Get info from IMAGING SITE PARAMETERS File
+ ; get the Network UserName and PassWord.
  S MAGRY(2)=$P($G(^MAG(2006.1,MAGPLC,"NET")),U,1,2)
- ;   get the default MUSE Site number.
+ ; get the default MUSE Site number.
  S MAGRY(3)=+$P($G(^MAG(2006.1,MAGPLC,"USERPREF")),U,2)
- ;   default to 1 if nothing is entered in Site Parameters File
+ ; default to 1 if nothing is entered in Site Parameters File
  I MAGRY(3)=0 S MAGRY(3)=1
  ; This SITEIEN^SITECODE^USER INSTITUTION IEN^INSTITUTION NAME^CONSOLIDATED^User's local STATION NUMBER
@@ -80,6 +80,6 @@
  S MAGJOB("PLCODE")=$$GET1^DIQ(2006.1,MAGPLC,.09)
  S MAGRY(4)=MAGRY(4)_U_$$CONSOLID^MAGBAPI_U_$$GET1^DIQ(4,DUZ(2),99,"E")
- ; is CP not installed at this site, the Client will hide options
- ;  related to CP.
+ ; is CP installed at this site, the Front End will hide options
+ ;  related to CP if not installed.
  S X=$$VERSION^XPDUTL("CLINICAL PROCEDURES")
  S MAGRY(5)=+X_U_X
@@ -158,6 +158,63 @@
  Q
 GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO]
- ; Call (3.0p8) to get information on 1 image 
- ; and Display in the Image Information Window
- D GETINFO^MAGGTU31(.MAGRY,IEN)
- Q
+ ; Call (3.0p8) to get information on 1 image
+ N Y,J,JI,I,CT,IENC,FLAGS,SNGRP,Z,M40,T,QACHK
+ S I=0,CT=0
+ S MAGRY(CT)="Image ID#:      "_IEN
+ I $D(^MAG(2005.1,IEN)) D  Q
+ . S CT=CT+1,MAGRY(CT)="    STATUS:  "_"HAS BEEN DELETED. !!"
+ . S CT=CT+1,MAGRY(CT)="Deleted By: "_$$GET1^DIQ(2005.1,IEN,30,"E")
+ . S CT=CT+1,MAGRY(CT)="    Reason: "_$$GET1^DIQ(2005.1,IEN,30.2,"E")
+ . S CT=CT+1,MAGRY(CT)="      Date: "_$$GET1^DIQ(2005.1,IEN,30.1,"E")
+ . Q
+ S M40=$G(^MAG(2005,IEN,40)),T=$P(M40,"^",3)
+ S Z=$P($G(^MAG(2005,IEN,0)),"^",10) I Z D
+ . S CT=CT+1,MAGRY(CT)=" is in Group#: "_Z_"  ("_+$P(^MAG(2005,Z,1,0),"^",4)_" images)"
+ . D CHK^MAGGSQI(.QACHK,Z) Q:QACHK(0) 
+ . S CT=CT+1,MAGRY(CT)=" QA Warning - Group#: "_Z_" "_$P(QACHK(0),"^",2)
+ . Q
+ S SNGRP="FLDS"
+ I (+$O(^MAG(2005,IEN,1,0)))!($P(^MAG(2005,IEN,0),"^",6)=11)!($P(^MAG(2005,IEN,0),"^",6)=16) D
+ . S CT=CT+1,MAGRY(CT)=$P(^MAG(2005,IEN,0),"^",8)_" Group of "_+$P($G(^MAG(2005,IEN,1,0)),U,4)
+ . S SNGRP="FLDG"
+ . Q
+ K QACHK
+ D CHK^MAGGSQI(.QACHK,IEN) I 'QACHK(0) D
+ . S CT=CT+1,MAGRY(CT)=" QA Warning - Image#: "_IEN_" "_$P(QACHK(0),"^",2)
+ N MAGOUT,MAGERR,MAGVAL
+ S IENC=IEN_","
+ S FLAGS="EN"
+ S I=-1
+ F  S I=I+1,Z=$T(@SNGRP+I) Q:$P(Z,";",3)="end"  D
+ . S J=$P(Z,";",4),JI=J_";"
+ . K MAGOUT
+ . S CT=CT+1,MAGRY(CT)=$P(Z,";",3)
+ . I J=41 D  Q  ; Need to compute the Class.  Class field in Image File is wrong.
+ . . S MAGVAL=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^MAG(2005.82,$P(^MAG(2005.83,T,0),"^",2),0),"^",1))
+ . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL
+ . . Q
+ . D GETS^DIQ(2005,IEN,JI,FLAGS,"MAGOUT","MAGERR")
+ . ; Get Extension from FileRef
+ . I J=1 S MAGVAL=$P($G(MAGOUT(2005,IENC,J,"E")),".",2)
+ . E  S MAGVAL=$G(MAGOUT(2005,IENC,J,"E"))
+ . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL
+ ; Compare Parent Association Date with Date/Time Note Signed.
+ I $P(^MAG(2005,IEN,0),"^",10) S IEN=$P(^MAG(2005,IEN,0),"^",10)
+ I $P(^MAG(2005,IEN,2),"^",6)=8925 S CT=CT+1,MAGRY(CT)=$$ATTSTAT^MAGGTU31(IEN)
+ Q
+ ;
+FLDS ;;Format:       ;3;;
+ ;;Extension:    ;1;;
+FLDG ;;Patient:      ;5;;
+ ;;Desc:         ;10;;
+ ;;Procedure:    ;6;;
+ ;;     Date:    ;15;;
+ ;;Class:        ;41;;
+ ;;Package:      ;40;;
+ ;;Type:         ;42;;
+ ;;Proc/Event:   ;43;;
+ ;;Spec/SubSpec: ;44;;
+ ;;Origin:       ;45;;
+ ;;Captured on:  ;7;;
+ ;;         by:  ;8;;
+ ;;end;;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU31.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU31.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU31.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGGTU31 ;WOIFO/GEK - Silent calls for Imaging ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20
+ ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023
  ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -62,98 +61,2 @@
  I MAGMED S J=J+1,MAGK(J)="MAGCAP MED"
  Q
-GETINFO(MAGRY,IEN) ; RPC [MAG4 GET IMAGE INFO]Called from MAGGTU3
- ; Call (3.0p8) to get information on 1 image 
- ; and Display in the Image Information Window
- N Y,J,JI,I,CT,IENC,FLAGS,SNGRP,Z,M40,T,QACHK,OBJTYP,VAL,LBL
- S I=0,CT=0
- S MAGRY(CT)="Image ID#:      "_IEN
- I $D(^MAG(2005.1,IEN)) D  Q
- . S CT=CT+1,MAGRY(CT)="    STATUS:  "_"HAS BEEN DELETED. !!"
- . S CT=CT+1,MAGRY(CT)="Deleted By: "_$$GET1^DIQ(2005.1,IEN,30,"E")
- . S CT=CT+1,MAGRY(CT)="    Reason: "_$$GET1^DIQ(2005.1,IEN,30.2,"E")
- . S CT=CT+1,MAGRY(CT)="      Date: "_$$GET1^DIQ(2005.1,IEN,30.1,"E")
- . Q
- S M40=$G(^MAG(2005,IEN,40)),T=$P(M40,"^",3)
- S Z=$P($G(^MAG(2005,IEN,0)),"^",10) I Z D
- . S CT=CT+1,MAGRY(CT)=" is in Group#: "_Z_"  ("_+$P(^MAG(2005,Z,1,0),"^",4)_" images)"
- . D CHK^MAGGSQI(.QACHK,Z) Q:QACHK(0) 
- . S CT=CT+1,MAGRY(CT)=" QA Warning - Group#: "_Z_" "_$P(QACHK(0),"^",2)
- . Q
- S OBJTYP=$P(^MAG(2005,IEN,0),"^",6)
- S SNGRP="FLDS"
- I (+$O(^MAG(2005,IEN,1,0)))!(OBJTYP=11)!(OBJTYP=16) D
- . S CT=CT+1,MAGRY(CT)=$P($G(^MAG(2005,IEN,40)),"^",1)_" Group of "_+$P($G(^MAG(2005,IEN,1,0)),U,4)
- . S SNGRP="FLDG"
- . Q
- K QACHK
- D CHK^MAGGSQI(.QACHK,IEN) I 'QACHK(0) D
- . S CT=CT+1,MAGRY(CT)=" QA Warning - Image#: "_IEN_" "_$P(QACHK(0),"^",2)
- N MAGOUT,MAGERR,MAGVAL,PKG
- S IENC=IEN_","
- S FLAGS="EN"
- S I=-1
- S PKG=""
- F  S I=I+1,Z=$T(@SNGRP+I) Q:$P(Z,";",3)="end"  D
- . S J=$P(Z,";",4),JI=J_";"
- . K MAGOUT
- . S CT=CT+1,MAGRY(CT)=$P(Z,";",3)
- . I J=41 D  Q  ; Need to compute the Class.  Class field in Image File is wrong.
- . . S MAGVAL=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^MAG(2005.82,$P(^MAG(2005.83,T,0),"^",2),0),"^",1))
- . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL
- . . Q
- . D GETS^DIQ(2005,IEN,JI,FLAGS,"MAGOUT","MAGERR")
- . ; Get Extension from FileRef
- . I J=1 S MAGVAL=$P($G(MAGOUT(2005,IENC,J,"E")),".",2)
- . E  S MAGVAL=$G(MAGOUT(2005,IENC,J,"E"))
- . S MAGVAL=$TR(MAGVAL,"&","+")
- . I J=40 S PKG=MAGVAL
- . I ((J>=50)&(J<=54)) D  Q
- . . I PKG'="LAB" K MAGRY(CT) Q
- . . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL
- . . Q
- . S MAGRY(CT)=MAGRY(CT)_" "_MAGVAL
- ; Compare Parent Association Date with Date/Time Note Signed.
- I $P(^MAG(2005,IEN,0),"^",10) S IEN=$P(^MAG(2005,IEN,0),"^",10)
- I $P(^MAG(2005,IEN,2),"^",6)=8925 S CT=CT+1,MAGRY(CT)=$$ATTSTAT^MAGGTU31(IEN)
- ;
- I (OBJTYP=11),($P($G(^MAG(2005,IEN,100)),"^",6)="") D
- . S X=$O(^MAG(2005,IEN,1,0))
- . S IEN=+$G(^MAG(2005,IEN,1,X,0))
- . Q
- I $P($G(^MAG(2005,IEN,100)),"^",6)]"" D
- . I OBJTYP=11 D  ; If a Group, get Object Type of First Child
- . . S Z=$O(^MAG(2005,IEN,1,0))
- . . I 'Z Q
- . . S Z=+$G(^MAG(2005,IEN,1,Z,0))
- . . S OBJTYP=+$P($G(^MAG(2005,Z,0)),"^",6) ; Object of First Child
- . . Q
- . S OBJTYP=","_OBJTYP_","
- . S LBL="",VAL=""
- . I ",3,9,10,12,100,"[OBJTYP S LBL="Image Creation Date: "           ; "Acquisition Date";
- . I ",15,101,102,103,104,105,"[OBJTYP S LBL="Document Creation Date: "
- . I LBL="" S LBL="Image Creation Date: "
- . S VAL=$$GET1^DIQ(2005,IEN,110,"E") S:(VAL="") VAL="N/A"
- . S CT=CT+1,MAGRY(CT)=LBL_VAL
- . Q
- Q
- ;
-FLDS ;;Format:       ;3;;
- ;;Extension:    ;1;;
-FLDG ;;Patient:      ;5;;
- ;;Desc:         ;10;;
- ;;Procedure:    ;6;;
- ;;     Date:    ;15;;
- ;;Class:        ;41;;
- ;;Package:      ;40;;
- ;;Type:         ;42;;
- ;;Proc/Event:   ;43;;
- ;;Spec/SubSpec: ;44;;
- ;;Origin:       ;45;;
- ;;Accession #   ;50;;
- ;;Specimen Desc ;51;;
- ;;Specimen#     ;52;;
- ;;Stain         ;53;;
- ;;Objective     ;54;;
- ;;Captured on:  ;7;;
- ;;         by:  ;8;;
- ;;end;;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU4.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU4.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU4.m	(revision 636)
@@ -1,5 +1,5 @@
-MAGGTU4 ;WOIFO/GEK - Imaging Client- Version checking routine; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**8,48,63,45,46,59,96**;April 29, 2008;Build 9
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+MAGGTU4 ;WOIFO/GEK - Testing callbacks for Delphi Doc Image Prototype ; 02/16/2007 13:37
+ ;;3.0;IMAGING;**8,48,63,45,46**;16-February-2007;;Build 1023
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -22,6 +22,6 @@
  ; The Server Version SVRVER needs hardcoded to match the Delphi Client.
  ; and This Routine must be distributed whenever a new Client is
- S SVRVER="3.0.96"
- S SVRTVER="4" ; This is the T version that the server expects
+ S SVRVER="3.0.46"
+ S SVRTVER=28 ; This is the T version that the server expects
  ; released Client will have the T version that the server expects
  S A("3.0.24")=5         ;Sept 2003
@@ -32,15 +32,10 @@
  S A("3.0.63")=4         ;June 2005
  S A("3.0.45")=8         ;Sept 2005
- S A("3.0.46")=28        ;Mar  2007
- S A("3.0.59")=31        ;Jul  2007
- S A("3.0.72")=21        ;Jan  2008
- S A("3.0.83")=24        ;Mar  2008
- S A("3.0.95")=5         ;Mar  2008
- S A("3.0.96")=4         ;Apr  2008
+ S A("3.0.59")=20        ;July 2006
  Q
  ;
 CHKVER(MAGRY,CLVER) ;RPC [MAG4 VERSION CHECK]
  ; CLVER is the version of the Delphi Client.
- ; CLVER format = Major.Minor.Patch.T-version
+ ; CLVER format = Major,Minor,Patch,T Version
  ; example : for Version 3.0 Patch 8 T 21 -->  CLVER=3.0.8.21
  ; Ver 2.5P9 (2.5.24.1) is first Delphi Ver that makes this call.
@@ -60,5 +55,5 @@
  I $P(CLVER,".",1)="30" S CLVER="3.0."_$P(CLVER,".",3,99)
  ;
- N PLC,SV,ST,SVSTAT,CV,CP,CT,OKVER,WARN,I,BETA
+ N PLC,SV,ST,SVSTAT,CV,CP,CT,OKVER,WARN,I
  ; PLC = Entry in 2006.1
  ; SV = Server Version -> (3.0.8) from (3.0.8.43) Hard coded to Sync with Delphi Clients
@@ -93,9 +88,8 @@
  D VERSTAT(.SVSTAT,SV)
  I 'SVSTAT S MAGRY(0)="2^"_$P(SVSTAT,"^",2) Q  ; There is not record of a KIDS for this Server.
- ; Set Alpha Beta Flag
- S BETA=(+SVSTAT=2)
+ ; 
  ;      If Client isn't one of the Supported Clients.
  I (CV'=SV),'$D(OKVER(CV)) D  Q
- . I BETA D NOTOKB^MAGGTU41(.MAGRY) Q
+ . I +SVSTAT=2 D NOTOKB^MAGGTU41(.MAGRY) Q
  . D NOTOK^MAGGTU41(.MAGRY) Q
  . Q 
@@ -104,8 +98,8 @@
  I (CV'=SV) D  Q
  . I CT<$G(OKVER(CV)) D  Q
- . . I BETA DO OKBADTB^MAGGTU41(.MAGRY) Q
+ . . I +SVSTAT=2 DO OKBADTB^MAGGTU41(.MAGRY) Q
  . . DO OKBADT^MAGGTU41(.MAGRY) Q
  . . Q
- . I BETA D OKB^MAGGTU41(.MAGRY)
+ . I +SVSTAT=2 D OKB^MAGGTU41(.MAGRY)
  . E  D OK^MAGGTU41(.MAGRY)
  . I WARN D WARNING
@@ -114,5 +108,5 @@
  ; At this point, Versions are the Same: If T versions are not, warn the Client.
  I CT,(CT'=ST) D  Q
- . I BETA D TNOTOKB^MAGGTU41(.MAGRY) Q
+ . I +SVSTAT=2 D TNOTOKB^MAGGTU41(.MAGRY) Q
  . D TNOTOK^MAGGTU41(.MAGRY) Q
  . Q
@@ -125,5 +119,4 @@
  ;
 NEEDWARN(WARN) ; This call determines if Client needs the warning.
- S WARN=0 Q  ; we don't need warning anymore.
  I $P($G(^MAG(2006.1,PLC,"USERPREF")),U,2)="" S WARN=0 Q  ; Not a MUSE Site.
  I $D(MAGJOB("CAPTURE")) S WARN=0 Q  ;Not needed for Capture Clients
@@ -173,6 +166,6 @@
  N VERI,TVER,MAGERR
  I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3)
- S VERI=$$FIND1^DIC(9.6,"","MO",MAGVER,"","","MAGERR")
- I 'VERI S MAGRY="0^There is No KIDs Install record for """_MAGVER_"""." Q
+ S VERI=$$FIND1^DIC(9.6,"","M",MAGVER,"","","MAGERR")
+ I 'VERI S MAGRY="0^There is No KIDs Install record." Q
  S TVER=$$GET1^DIQ(9.6,VERI_",","ALPHA/BETA TESTING")
  I TVER="YES" S MAGRY="2^Alpha/Beta Version." Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU41.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU41.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU41.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGGTU41 ;WOIFO/GEK - Version Control utilities  ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20
+ ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023
  ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -45,5 +44,5 @@
  I $P(CV,".",1)=2 S X(50)="(clicking 'Cancel' will not stop the Abort.)"
  Q
-OKBADTB(X) ; Client not Equal, Is supported. Previous Supported Version. Beta
+OKBADTB(X) ; Client not Equal, but it is supported.
  ;  But it's T isn't the T of it's Released Patch
  S X(0)="0^   Server is running Imaging V. "_SV_"      "_$P(SVSTAT,"^",2)
@@ -59,5 +58,5 @@
  S X(30)="                          APPLICATION will Continue  "
  Q
-OKBADT(X) ; Client not Equal, but it is supported.  Previous Supported Version
+OKBADT(X) ; Client not Equal, but it is supported.
  ;  But it's T isn't the T of it's Released Patch
  S X(0)="2^   Server is running Imaging V. "_SV_"      "_$P(SVSTAT,"^",2)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU6.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU6.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU6.m	(revision 636)
@@ -1,4 +1,4 @@
-MAGGTU6 ;WOIFO/GEK - Silent Utilities ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**24,8,48,45,20,46,59**;Nov 27, 2007;Build 20
+MAGGTU6 ;WOIFO/GEK - Silent Utilities ; 25 Jan 2006  12:14 PM
+ ;;3.0;IMAGING;**24,8,48,45,20,46**;16-February-2007;;Build 1023
  ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -9,5 +9,4 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
- ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU71.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU71.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU71.m	(revision 636)
@@ -1,5 +1,5 @@
 MAGGTU71 ;WOIFO/GEK - Silent calls for Queing functions from GUI, cont ;  [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**46,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**46**;16-February-2007;;Build 1023
+ ;; Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -17,7 +17,7 @@
  ;;
  Q
-ABSJB(MAGRY,DATA) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES
+ABSJB(MAGRY,MAGIN) ;RPC [MAG ABSJB] SET ABSTRACT AND/OR JUKEBOX QUEUES
  ;
- ;       DATA
+ ;       MAGIN
  ;   DESCRIPTION:  '^' delimited String:
  ;   Piece 1 = the IEN of the image that needs an abstract created.
@@ -31,5 +31,5 @@
  N $ETRAP,$ESTACK S $ETRAP="D ERR^"_$T(+0)
  S MAGRY="0^ERROR: Setting Queue for Abstract or JukeBox copy"
- S MAGIENAB=+$P(DATA,"^",1),MAGIENJB=+$P(DATA,"^",2)
+ S MAGIENAB=+$P(MAGIN,"^",1),MAGIENJB=+$P(MAGIN,"^",2)
  I MAGIENAB Q:((+$P($G(^MAG(2005,MAGIENAB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENAB,0)),U,12))) "0^Image integrity"
  I MAGIENJB Q:((+$P($G(^MAG(2005,MAGIENJB,0)),U,11))!(+$P($G(^MAG(2005,MAGIENJB,0)),U,12))) "0^Image integrity"
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU9.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTU9.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTU9.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTU9 ;WOIFO/LB/GEK - Imaging utilities assign key
- ;;3.0;IMAGING;**8,59**;Nov 27, 2007;Build 20
- ;; Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8**;Sep 15, 2004
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -18,101 +17,54 @@
  ;;
  Q
-CHKKEY ;
- N NOGIVE
- S NOGIVE=1
-GIVEKEY ;Give MAGDISP CLIN key to all MAG WINDOWS option holders
- ; that have neither MAGDISP CLIN nor MAGDISP ADMIN
+EN ;Give MAGDISP CLIN key to all MAG WINDOWS option holders.
  ;   Find the menu option's IEN
- N MKEYC,MKEYA,ERR,OPT,MAGUSER,I,KEYCLIN,KEYADMIN,KEYCT,KEYECT,XCT
- N KEYHASC,KEYHASA,KEYHASB,KEYNONE,SP,LSP
- N UCT,UTOT,OPTACC,MDOT,UDISCT
- ; This could be made Generic if ever a need, to search for users 
- ; withour either key, and assigned those users the first (KEYCLIN)
- S KEYCLIN="MAGDISP CLIN"
- S KEYADMIN="MAGDISP ADMIN"
+ N MKEY,ERR,OPT,MAGUSER,I,KEYNM,KEYCT,KEYECT,XCT,KEYHAS
+ N UCT,UTOT,OPTACC,MDOT
+ S KEYNM="MAGDISP CLIN"
  S KEYCT=0 ; count of number of users that were assigned the key.
  S KEYECT=0 ; count of number of errors during the assignment.
- S KEYHASC=0 ; count of number of users that already have key Clin
- S KEYHASA=0 ; count of number of users that already have key Admin
- S KEYHASB=0 ; count of number of users that Have Both keys
- S KEYNONE=0 ; count of Users that have Neither Key.
+ S KEYHAS=0 ; count of number of users that already have key.
  S OPTACC=0 ; count of users with access to MAG WINDOWS.
- S UDISCT=0 ; count of Disabled Users Skipped.
  S MDOT=10000 ; print '.' to screen to show progress.
  S UCT=0 ; user count. for progress
  S UTOT=$P(^VA(200,0),"^",4)
- ;
- I $G(NOGIVE) D 
- . D MES^XPDUTL("Checking for users that have access to Option : "_"MAG WINDOWS")
- . D MES^XPDUTL("  but do not have either '"_KEYCLIN_"' or '"_KEYADMIN_"' Keys")
- . D MES^XPDUTL("  Disabled users (DISUSER=1) are skipped, they are not checked.")
- . Q
- E  D MES^XPDUTL("Assigning "_KEYCLIN_" to all users with access to Option : "_"MAG WINDOWS")
- D MES^XPDUTL("  ")
+ ; 
+ D MES^XPDUTL("Assigning "_KEYNM_" to all users with access to Option : "_"MAG WINDOWS")
  S OPT=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","ERR")
  I OPT="" D MES^XPDUTL("ERROR ",$G(ERR("DIERR",1,"TEXT",1))) Q
  I OPT=0 D MES^XPDUTL("MAG WINDOWS wasn't found in Option File") Q
  ;   Lookup the security key
- S MKEYC=$$LKUP^XPDKEY(KEYCLIN)
- S MKEYA=$$LKUP^XPDKEY(KEYADMIN)
- I ('MKEYC)!('MKEYA) D MES^XPDUTL("ERROR: Imaging Display Keys are not defined at this site") Q
- ;   Check all Users at site to see if they don't have either Clin or Admin
+ S MKEY=$$LKUP^XPDKEY(KEYNM)
+ I 'MKEY D MES^XPDUTL("ERROR "_KEYNM_" Key wasn't found") Q
+ ;   Give users the Key, if they don't have it already
  D MES^XPDUTL("Checking users...")
- D MES^XPDUTL(" ")
  S I=0 F  S I=$O(^VA(200,I)) Q:'I  D
- . I $$GET1^DIQ(200,I,7,"E")]"" S UDISCT=UDISCT+1 Q
  . S UCT=UCT+1 I UCT>MDOT S MDOT=MDOT+10000 D MES^XPDUTL(UCT_" of "_UTOT_" users checked...")
- . I (($$ACCESS^XQCHK(I,OPT))>0) S OPTACC=OPTACC+1 D C(I)
+ . I (($$ACCESS^XQCHK(I,OPT))>0) S OPTACC=OPTACC+1 D GIVEKEY(MKEY,KEYNM,I)
  . Q
- S SP="          "
- S LSP=$L(UTOT)+3
- D MES^XPDUTL("   ")
- I $G(NOGIVE) D
- . D MES^XPDUTL($E(SP,1,LSP-$L(OPTACC))_OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.")
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASB))_KEYHASB_" Users have Both Keys ")
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASC))_KEYHASC_" Users only have "_KEYCLIN_" key")
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASA))_KEYHASA_" Users only have "_KEYADMIN_" key")
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYNONE))_KEYNONE_" Users have neither Key")
- . I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details")
- . Q
- I '$G(NOGIVE) D
- . D MES^XPDUTL($E(SP,1,LSP-$L(OPTACC))_OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.")
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASB))_KEYHASB_" Users already have Both Keys ")
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASC))_KEYHASC_" Users have Only Key "_KEYCLIN)
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYHASA))_KEYHASA_" Users have Only Key "_KEYADMIN)
- . D MES^XPDUTL($E(SP,1,LSP-$L(KEYCT))_KEYCT_" Users were assigned key: "_KEYCLIN)
- . D MES^XPDUTL("Assignment Complete.")
- . I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details")
- . Q
+ D MES^XPDUTL(OPTACC_" of "_UTOT_" Users have access to option MAG WINDOWS.")
+ D MES^XPDUTL(KEYHAS_" Users already have Key "_KEYNM)
+ D MES^XPDUTL(KEYCT_" Users were assigned key: "_KEYNM)
+ D MES^XPDUTL("Assignment Complete.")
+ I KEYECT>0 D MES^XPDUTL(KEYECT_" Errors during Key Assignment. See install log for details")
  Q
-C(USER) ;
- ; check KEY for USER
- N DO,D1,MFDA,ZC,ZA,MIEN
- ; check to see if they have the Clin key
- S ZC=$$FIND1^DIC(200.051,","_USER_",","",KEYCLIN)
- I ZC="" D  Q
- . D MES^XPDUTL("ERROR Validating that user ("_USER_") has Key "_KEYCLIN)
+GIVEKEY(KEY,KEYNM,USER) ;
+ ; Give KEY to USER
+ N DO,D1,MFDA,Z,MIEN
+ ; Quit if they already have the key
+ S Z=$$FIND1^DIC(200.051,","_USER_",","",KEYNM)
+ I +Z S KEYHAS=KEYHAS+1
+ Q:Z  ; Already have key
+ I Z="" D  Q
+ . D MES^XPDUTL("ERROR Validating that user ("_USER_") has key ("_KEYNM_")")
  . S KEYECT=KEYECT+1
- . Q
- ; check to see if they have the Admin key
- S ZA=$$FIND1^DIC(200.051,","_USER_",","",KEYADMIN)
- I ZA="" D  Q
- . D MES^XPDUTL("ERROR Validating that user ("_USER_") has Key "_KEYADMIN)
- . S KEYECT=KEYECT+1
- . Q
- I ((+ZC)&(+ZA)) S KEYHASB=KEYHASB+1 Q
- I +ZC S KEYHASC=KEYHASC+1 Q
- I +ZA S KEYHASA=KEYHASA+1 Q
- S KEYNONE=KEYNONE+1
- I $G(NOGIVE) D  Q
- . D MES^XPDUTL("User: "_$P($G(^VA(200,USER,0)),"^")_" has neither Key")
- . Q
- S MFDA(200.051,"+1,"_USER_",",.01)=MKEYC
+ ;
+ S MFDA(200.051,"+1,"_USER_",",.01)=KEY
  S MFDA(200.051,"+1,"_USER_",",1)=DUZ
  S MFDA(200.051,"+1,"_USER_",",2)=DT
- S MIEN(1)=MKEYC_","
+ S MIEN(1)=KEY_","
  D UPDATE^DIE("","MFDA","MIEN")
  I $D(DIERR) D  Q
- . D MES^XPDUTL("ERROR Assigning Key ("_KEYCLIN_") to user ("_USER_")")
+ . D MES^XPDUTL("ERROR Assigning key ("_KEYNM_") to user ("_USER_")")
  . S KEYECT=KEYECT+1
  . D CLEAN^DILF
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTUP.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGGTUP.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGGTUP.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGGTUP ;WOIFO/GEK - Imaging System User preferences ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**7,8,48,45,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,48,45**;Sep 12, 2005
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -116,9 +115,7 @@
  S ARR($J,"GROUP")="2^24^231^427^457^110^70^^1^2^24^2^1^0"
  S ARR($J,"DOC")="2^298^24^729^429^0^0^3^1^2^4^2^0"
- S ARR($J,"CAPCONFIG")="1^1^1^0^0^0^0^1^0^1^0^0^1^1^0^0^1^1^1^1^1^1^200^400^300^100^500^0^0^1^0^1"
- ;                    1   2   3   4   5  6  7  8 9 0 1  2   3  456 7 8
- S ARR($J,"CAPTIU")="261^414^455^654^66^67^280^1^1^~^1^100^-12^^^1^1^^"
+ S ARR($J,"CAPCONFIG")="1^1^1^0^0^0^0^1^0^1^0^0^1^1^0^0^1^1^1^1^1^1^200^400^300^100^500^0^0^1^"
+ S ARR($J,"CAPTIU")="5^369^760^654^289^67^170^1^1^"
  S ARR($J,"RIVER")="1^0^0^0^"
- S ARR($J,"APPMSG")="0^0^"
  S ARR($J,"APPPREFS")="1^7^7^10"
  S ARR($J,"LISTWIN1")="1^1^^1^1"
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJEX1B.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJEX1B.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJEX1B.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJEX1B ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003  9:58 AM
- ;;3.0;IMAGING;**16,22,18,65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**16,22,18,65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -115,5 +115,5 @@
  . D LOCKOUT^MAGJEX1A(RARPT,DAYCASE,.LOCKLEV,.MYLOCK,ACTION,.RESULT) ; 1st, lock to me
  . K LOCKLEV,MYLOCK D LOCKACT^MAGJEX1A(RARPT,DAYCASE,101,.RESULT) ;    then, clear the lock
- S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0)
+ S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X
  S ^XTMP("MAGJ",0)=TS_U_"VistaRad Locks"
  Q
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJEX2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJEX2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJEX2.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJEX2 ;;WIRMFO/JHC Rad. Workstation RPC calls;[ 02/25/2000  4:40 PM ] ; 09 Jun 2003  2:58 PM
- ;;3.0;IMAGING;**51,18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**51,18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -87,5 +86,5 @@
  S X=$G(^MAG(2006.69,1,0))
  S LIMYRS=+$P(X,U,14),LIMEXAMS=+$P(X,U,15)
- S:'LIMYRS LIMYRS=7 S:'LIMEXAMS LIMEXAMS=50 ; default limit # Exams
+ S:'LIMYRS LIMYRS=10 S:'LIMEXAMS LIMEXAMS=100 ; default limit # Exams
  S BEGDT=($E(DT,1,3)-LIMYRS)_$E(DT,4,7)
  I BEGDT<2950101 S BEGDT=2950101 ; 2 yrs prior to earliest VistaPACS
@@ -137,9 +136,9 @@
  ;
  Q:'MAGMATCH
- ; 1  RADFN   RADTI    RACNI   RANME   RASSN    <-- from GETEXAM
- ; 6  RADATE  RADTE    RACN    RAPRC   RARPT
- ; 11 RAST    DAYCASE  RAELOC  RASTP   RASTORD
- ; 16 RADTPRT RACPT    RAIMGTYP
- S MAGDTH=$$FMTH^XLFDT($P(RADATA,U,7),1)
+   ; 1  RADFN   RADTI    RACNI   RANME   RASSN    <-- from GETEXAM
+   ; 6  RADATE  RADTE    RACN    RAPRC   RARPT
+   ; 11 RAST    DAYCASE  RAELOC  RASTP   RASTORD
+   ; 16 RADTPRT RACPT    RAIMGTYP
+ S X=$P(RADATA,U,7) D H^%DTC S MAGDTH=+%H
  S X=$P(RADATA,U,18)
  S RAIMGTYP=$S(X]"":$O(^RA(79.2,"C",X,"")),1:X)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLS2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJLS2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLS2.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJLS2 ;WIRMFO/JHC Rad. Workstation RPC calls ; 29 Jul 2003  9:58 AM
- ;;3.0;IMAGING;**22,18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**22,18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -19,5 +18,5 @@
  Q
  ;  ACTIVE -- list exams (Unread, Recent, &/or Pending) for input Imaging Type(s)
- ;    RPC Call: MAGJ RADACTIVEEXAMS
+ ;       RPC Call: MAGJ RADACTIVEEXAMS
  ;  BKGND -- EP for Bkgnd Compile of UNREAD list
  ;  BKGND2 -- EP for Bkgnd Compile of RECENT list
@@ -39,5 +38,4 @@
  S X=$P(DATA,U) D PARAMS^MAGJLS2B(X)
  I 'LSTID S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with Exams List Compile--"_DATA_"." Q
- I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~VistARad Patch 32 is no longer supported.  Contact Imaging support for the current version of the VistARad client software." Q  ; <*>
  I BKGND,LSTREQ="U" D BKREQU Q  ; UNREAD in bkgnd
  I BKGND,LSTREQ="R" D BKREQR Q  ; RECENT in bkgnd
@@ -89,5 +87,4 @@
  I +$G(COMPFAIL) S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Unable to Compile Unread Exams list"
  E  D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE)
- K LSTAGE
  Q
  ;
@@ -100,5 +97,4 @@
  I 'LSTNUM S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with "_LSTNM_" List Compile program (age="_LSTAGE_" for "_LSTNAM_")"_$S(LSTNAM["9992":"--May need to Schedule RECENT List Compile in TaskMan.",1:"")
  E  D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^XTMP("MAGJ2",LSTNAM,LSTNUM)),LSTAGE)
- K LSTAGE
  Q
  ;
@@ -117,5 +113,4 @@
  . D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,$NA(^TMP($J,"MAGJ")))
  I 'ALLGO S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)="0^4~Problem with ALL Exams List Compile "_DATA_". "_REPLY
- K LSTAGE
  Q
  ;
@@ -151,25 +146,33 @@
  D LSTCOMP()
  I LSTREQ="R" D NEWINT
- I LSTREQ="U" D UPDR^MAGJLS2B G BKLOOP  ;UNREAD loops; RECENT uses TaskMan
+ I LSTREQ="U" D UPDR G BKLOOP  ;UNREAD loops; RECENT uses TaskMan
 BKGNDZ I LSTREQ="U" L -^XTMP("MAGJ2","BKGND2","RUN")
  N ZTREQ S ZTREQ="@"  ;  clean up task entry
- K BKLOOP,DELTA,LSTAGE
+ K BKLOOP,DELTA
  Q  ; Exit bkgnd
  ;
-NEWINT ; Add exams newly Interp since Recent Compile started to Recent List
- ; 1st, get list of candidates:
+UPDR ; Add Newly Interp exams to Recent
+ D PARAMS^MAGJLS2B(9995)
+ I 'LSTID G UPDRZ
+ S X=$$CURLIST(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X
+ D LSTCOMP()
+UPDRZ Q  ;
+ ;
+NEWINT ; Exams newly Interp since Recent Compile started
+ ; are added to Recent List (add to "RECENT" index)
+ ; 1st, get list of all potential candidates:
  N INDX L +^XTMP("MAGJ2","RECENT"):15
  E  Q
  S INDX=+$G(^TMP($J,"NEWINT")) ; counter when Recent Compile started
  I INDX S INDX=INDX-1 F  S INDX=$O(^XTMP("MAGJ2","RECENT",INDX)) Q:'INDX  S X=^(INDX) I X S ^TMP($J,"NEWINT",0,INDX)=X
- K ^XTMP("MAGJ2","RECENT") S ^("RECENT",0)=0
+ K ^XTMP("MAGJ2","RECENT") S ^("RECENT",0)=0 ; init this index
  L -^XTMP("MAGJ2","RECENT")
- ;if not in Recent Compile, add to index
+ ;find those not included in Recent Compile, and add to index
  S INDX=""
  F  S INDX=$O(^TMP($J,"NEWINT",0,INDX)) Q:'INDX  S X=^(INDX) D
- . I $D(^TMP($J,"NEWINT",$P(X,U,1,3))) Q  ; already there
+ . I $D(^TMP($J,"NEWINT",$P(X,U,1,3))) Q  ; already in the compile
  . L +^XTMP("MAGJ2","RECENT"):15
  . E  Q
- . S I=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=I,^(I)=X ;add 
+ . S I=+$G(^XTMP("MAGJ2","RECENT",0))+1,$P(^(0),U)=I,^(I)=X ; add to indx
  . L -^XTMP("MAGJ2","RECENT")
  K ^TMP($J,"NEWINT")
@@ -178,9 +181,9 @@
 LSTCOMP(COMPFAIL) ; Compile new list; subrtn used by Active and Bkgnd tags
  S COMPFAIL=0 ; Return T/F for "Executed a List Compile?"
- L +^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE"):60
+ L +^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE"):60 ; shouldn't need any time
  E  S COMPFAIL=1 G LSTCOMZ
- S NEWLIST=$S(LSTNUM=1:2,1:1) ; toggle node to use
+ S NEWLIST=$S(LSTNUM=1:2,1:1) ; toggle node to use for new compile
  N TS,COMTIM
- S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0)
+ S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X
  S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile"
  S ^XTMP("MAGJ2",0,LSTNAM,NEWLIST)=$H
@@ -194,5 +197,7 @@
 LSTCOMZ L -^XTMP("MAGJ2","BKGND",LSTNAM,"COMPILE")
  Q  ;
-CURLIST(LSTNAM,WAIT) ; return cur. list & age in secs
+ ;
+CURLIST(LSTNAM,WAIT) ; return current list & its age in seconds
+ ;
  S WAIT=+$G(WAIT)
  N X,RET,AGE,TRY,START,EXTRATIM
@@ -204,11 +209,11 @@
 CURLISZ Q RET
  ;
-DELTA(X,Y) ; calc # secs bet 2 $h values; dflt 2nd value = now
+DELTA(X,Y) ; calc # seconds between 2 $h values; default 2nd value = now
  ; useful limit is one day
  I $G(Y)="" S Y=$H
  I +Y=+X
  E  D
- . I Y-X=1 S $P(Y,",",2)=86400+$P(Y,",",2)  ; midnight boundary
- . E  S $P(X,",",2)=0,$P(Y,",",2)=86400  ; > one day
+ . I Y-X=1 S $P(Y,",",2)=86400+$P(Y,",",2)  ; cross midnight boundary
+ . E  S $P(X,",",2)=0,$P(Y,",",2)=86400  ; more than one day
  Q ($P(Y,",",2)-$P(X,",",2))
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLS2B.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJLS2B.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLS2B.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJLS2B ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003  9:59 AM
- ;;3.0;IMAGING;**16,22,18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**16,22,18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -188,10 +187,4 @@
  Q
  ;
-UPDR ; Add Newly Interp exams to Recent; called from magjls2
- D PARAMS(9995)
- I LSTID D
- . S X=$$CURLIST^MAGJLS2(LSTNAM),LSTAGE=$P(X,U,2),LSTNUM=+X
- . D LSTCOMP^MAGJLS2()
-UPDRZ Q
+END Q  ;
  ;
-END ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLS4.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJLS4.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLS4.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJLS4 ;WIRMFO/JHC VistARad RPCs--History List ; 29 Jul 2003  10:00 AM
- ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -57,5 +56,5 @@
  ;
 HISTADD(DATA,TXDUZ,TXDIV) ; add records
- N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT,TS
+ N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT
  S IDATA="",CT=0,NOGO=0
  F ILOOP=0:1 S IDATA=$O(DATA(IDATA)) Q:IDATA=""  D
@@ -72,5 +71,5 @@
  S MAGRACNT=0 D ACTIVE^MAGJLS2(.MAGGRY,9996)
  S X=@MAGGRY@(0),X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV),@MAGGRY@(0)=X
- S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0)
+ N TS S TS="" F I=2,0 S %H=$H+I D YMD^%DTC S TS=TS_$S(TS="":"",1:U)_X
  S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile"
  S REPLY=1
@@ -134,6 +133,6 @@
  . S HDATE=$P(XX2,U,13) D  Q:DELETED
  . . S DELETED=0,HDATE=$P(HDATE,"@")
- . . S X=HDATE,%DT="" D ^%DT K %DT
- . . I $$FMTH^XLFDT(Y,1)<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q
+ . . S X=HDATE,%DT="" D ^%DT S X=Y D H^%DTC K %DT
+ . . I %H<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q
  . ; <*> End of temp change
  . I RARPT,RADFN,RADTI,RACNI
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLST1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJLST1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJLST1.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJLST1 ;WIRMFO/JHC VistARad RPC calls ; 29 Jul 2003  10:01 AM
- ;;3.0;IMAGING;**16,22,18,65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**16,22,18,65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -43,10 +43,9 @@
  ; 
  ; MAGGRY - indirect reference to return array of exams for a patient
- ; DATA   - DFN ^ LIMYEARS ^ LIMEXAMS ^ BEGDT ^ ONESHOT
+ ; DATA   - DFN ^ LIMYEARS ^ LIMEXAMS ^ BEGDT
  ;   DFN--Patient's DFN
- ;   LIMYRS--Restrict exams up to # Years back (defunct)
+ ;   LIMYRS--Restrict exams up to # Years back
  ;   LIMEXAMS--Restrict exams up to # of exams
  ;   BEGDT--Begin date for exam fetch (Patch 18 addition--see below)
- ;   ONESHOT--Number days back to search, in one fell swoop
  ; Returns data in ^TMP($J,"MAGRAEX",0:n)
  ; RPC Call: MAGJ PTRADEXAMS
@@ -64,6 +63,6 @@
  N CNT,DFN,ISS,PATNAME,DIQUIET,MAGRACNT,MAGRET,REPLY,REMOTE,SNDREMOT
  N DAYCASE,DIV,EXCAT,MAGDT,XX,XX2,WHOLOCK,MODALITY,MYLOCK,PLACE,ENDLOOP
- N LIMEXAMS,BEGDT,SAVBEGDT,ENDDT,MORE,SHOWPLAC,RDRIST,PSSN,CPT,PARAM
- N CURPRIO,STATUS,RARPT,KEY,X2,REMOTE2,ONESHOT,LIMDAYS
+ N LIMYRS,LIMEXAMS,BEGDT,SAVBEGDT,ENDDT,MORE,SHOWPLAC,RDRIST,PSSN,CPT,PARAM
+ N CURPRIO,STATUS,RARPT,KEY,X1,X2,REMOTE2,ONESHOT,LIMDAYS
  N IMGCNT,LRFLAG,MSG,ONL,PROCMOD,RASTCAT,RASTORD
  N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLST1"
@@ -79,4 +78,7 @@
  E  S BEGDT=$P(DATA,U,4),ONESHOT=$P(DATA,U,5)  ; P65 chg
  K MAGGRY S DFN=+DATA
+ ;<*>
+ ; I DUZ=131 G MANYTST^ZMAGJTST ; <*> TEST ONLY !!!  37=RadRes
+ ;<*>
  S SHOWPLAC=$$SHOWPLAC^MAGJLS2B("")
  S MAGRACNT=1,CNT=0 K ^TMP($J,"MAGRAEX"),^("MAGRAEX2")
@@ -84,12 +86,10 @@
  I DFN,$D(^DPT(DFN,0)) S PATNAME=$P(^(0),U),PSSN=$P(^(0),U,9) D
  . S ENDLOOP=0,BEGDT=$S(+BEGDT:BEGDT,1:"")
- . I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S REPLY="0^4~VistARad Patch 32 is no longer supported; contact Imaging Support for the current version of the VistARad client software." Q  ; <*>
- . F  D  Q:'MORE  Q:ENDLOOP  S BEGDT=MORE+1
+ . F  D  Q:'MORE  Q:ENDLOOP
  . . I 'BEGDT S BEGDT=DT,X2=0
  . . E  S X2=-1
- . . S LIMDAYS=365,MORE=1
- . . I 'MAGJOB("P32") I ONESHOT,(ONESHOT>0) S LIMDAYS=+ONESHOT
- . . S ENDDT=$$FMADD^XLFDT(BEGDT,X2)
- . . S BEGDT=$$FMADD^XLFDT(ENDDT,-LIMDAYS)
+ . . S LIMDAYS=365
+ . . I 'MAGJOB("P32"),ONESHOT,(ONESHOT>0) S LIMDAYS=+ONESHOT
+ . . S X1=BEGDT D C^%DTC S (ENDDT,X1)=X,X2=-LIMDAYS D C^%DTC S BEGDT=X K %,%H,%T
  . . D GETEXAM3^MAGJUTL1(DFN,BEGDT,ENDDT,.MAGRACNT,.MAGRET,.MORE)
  . . I MAGJOB("P32") S ENDLOOP=(MAGRACNT>LIMEXAMS)
@@ -109,5 +109,4 @@
  . E  S REPLY=REPLY_" -- "_MSG
  . S ^TMP($J,"MAGRAEX2",1)="^Day/Case~S3~1^Lock~~2^Procedure~~6^Modifier~~25^Image Date/Time~S1~7^Status~~8^# Img~S2~9^Onl~~10"_$S($G(SNDREMOT):"^RC~~12",1:"")_$S(SHOWPLAC:"^Site~~23",1:"")_"^Mod~~15^Interp By~~20^Imaging Loc~~11^CPT~~27"
- I MAGJOB("P32"),+$G(MAGJOB("P32STOP")) S ^TMP($J,"MAGRAEX2",1)="^^"
  I 'MAGJOB("P32") S $P(REPLY,"|",2)=SAVBEGDT
  S ^TMP($J,"MAGRAEX2",0)=REPLY
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJMN1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJMN1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJMN1.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJMN1 ;WIRMFO/JHC VRad Maint functions ; 29 Jul 2003  4:02 PM
- ;;3.0;IMAGING;**16,9,22,18,65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**16,9,22,18,65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -31,5 +31,5 @@
  D ENSRCH
  D BLDDEF(MAGIEN)
- S $P(^MAG(2006.631,MAGIEN,0),U,5)=$$NOW^XLFDT()
+ D NOW^%DTC S $P(^MAG(2006.631,MAGIEN,0),U,5)=%
  W !!,"List Definition complete!" R X:2
  G SVRLIST
@@ -115,5 +115,5 @@
  . S STR=STR_$S(STR="":"",1:U)_X
  S ^MAG(2006.631,LSTID,"DEF",2)=STR
- S $P(^MAG(2006.631,LSTID,"DEF",0),U)=$$NOW^XLFDT()
+ D NOW^%DTC S $P(^MAG(2006.631,LSTID,"DEF",0),U)=%
  Q
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUPD1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUPD1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUPD1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJUPD1 ;WOIFO/JHC VistARad Update Exam Status ; 29 Jul 2003  10:02 AM
- ;;3.0;IMAGING;**16,22,18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**16,22,18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -45,5 +44,5 @@
  K MAGGRY S MAGGRY=$NA(^TMP($J,MAGLST)) K @MAGGRY  ; assign MAGGRY value
  S DIQUIET=1 D DT^DICRW
- S TIMESTMP=$$NOW^XLFDT()
+ D NOW^%DTC S TIMESTMP=%
  S UPDFLAG=$P(PARAMS,U),RADFN=$P(PARAMS,U,2),RADTI=$P(PARAMS,U,3),RACNI=$P(PARAMS,U,4),RARPT=$P(PARAMS,U,5),UPDPSKEY=+$P(PARAMS,U,6)
  S REPLY="0^4~Closing case with"_$S(UPDFLAG:"",1:" NO")_" Status Update"
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUPD2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUPD2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUPD2.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJUPD2 ;WIRMFO/JHC VistaRad RPCs-Update PS & KEY Img ; 14 July 2004  10:05 AM
- ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -33,5 +32,5 @@
  S (IMGCT,PSTOT,PSLINCT,KEYCT,INTCT,PSKILCT)=0
  S IMGREF="",SAVOP="NOOP"
- I '$D(TIMESTMP) N TIMESTMP S TIMESTMP=$$NOW^XLFDT()
+ I '$D(TIMESTMP) N TIMESTMP D NOW^%DTC S TIMESTMP=%
  ; 1st, process input in DATA
  S IDATA=""
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL1.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJUTL1 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 29 Jul 2003  10:03 AM
- ;;3.0;IMAGING;**22,18,65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**22,18,65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -25,6 +25,5 @@
  ;
 GETEXAM3(DFN,BEGDT,ENDT,MAGRACNT,MAGRET,MORE,LIMEXAMS) ; Get data for all exams for a
- ; pt within a date range
- ; limit to LIMEXAMS entries--note, only PREFETCH & Auto-route Priors use this
+ ; pt within a date range (default all dates); limit returned list to LIMEXAMS
  ; Input:
  ;      DFN -- Patient DFN
@@ -32,5 +31,4 @@
  ;     ENDT -- Opt, latest date desired
  ; MAGRACNT -- Opt, pass by ref to init counter to ref return data in ^TMP (see GETEXSET)
- ;    MORE -- Opt, If True, check for additional exams for pt
  ; LIMEXAMS -- Opt, limit # exams to return
  ; Return:
@@ -41,7 +39,8 @@
  ;
  I '$D(DT) N DIQUIET S DIQUIET=1 D DT^DICRW
+ N MORECHK
  S LIMEXAMS=+$G(LIMEXAMS)
+ S MORECHK=BEGDT!LIMEXAMS
  S:$G(BEGDT)="" BEGDT=2010101 S:$G(ENDT)="" ENDT=DT ; default all dates
- N MORECHK S MORECHK=+$G(MORE)
  S MAGRACNT=+$G(MAGRACNT),MAGRET=0,MORE=0  ; Init return data
  I BEGDT>ENDT S X=ENDT,ENDT=BEGDT,BEGDT=X
@@ -54,13 +53,10 @@
  K ^TMP($J,"RAE1")
  I 'MORECHK Q  ; all done; else indicate if pt has more exams
- N DTI,CNI,STS,DTCHK
+ N DTI,CNI,STS
  I 'MAGRET S DTI=9999999.9999-BEGDT,CNI=0 ; no exam found in orig dt range
  E  S X=^TMP($J,"MAGRAEX",MAGRACNT,1),DTI=$P(X,U,2),CNI=$P(X,U,3) ; last exam processed
  ; loop thru addl exams til find one that is NOT Cancelled
 MORE1 F  S CNI=$O(^RADPT(DFN,"DT",DTI,"P",CNI)) Q:'CNI  S STS=$P($G(^(CNI,0)),U,3) I STS]"" D  Q:MORE
- . Q:($P($G(^RA(72,STS,0)),U,3)=0)  ; Canceled--keep looking
- . S DTCHK=9999999.9999-DTI D EN1^RAO7PC1(DFN,DTCHK,DTCHK,1)  ; verify there is at least one "good" exam for this date (Remedy #200480)
- . I +$O(^TMP($J,"RAE1",DFN,0)) S MORE=1
- . K ^TMP($J,"RAE1")
+ . S MORE='($P($G(^RA(72,STS,0)),U,3)=0) ; True if sts is NOT Canc
  I 'MORE S DTI=$O(^RADPT(DFN,"DT",DTI)),CNI=0 G MORE1:DTI
  I MORE S MORE=9999999.9999-DTI\1
@@ -131,5 +127,5 @@
  . S IEN=0
  . F  S IEN=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",IEN)) Q:'IEN  S X=$P($G(^(IEN,0)),U) I X D
- . . S X=$P($$MOD^ICPTMOD(X,"I"),U,3) Q:X=""  S X=$$TRIM(X)
+ . . S X=$P($G(^DIC(81.3,X,0)),U,2) Q:X=""  S X=$$TRIM(X)
  . . S X=$S(X="LEFT SIDE":"LEFT",X="RIGHT SIDE":"RIGHT",X="BILATERAL PROCEDURE":"BILAT",1:X)
  . . S CT=CT+1,MODS(CT)=X
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL2.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJUTL2 ;WIRMFO/JHC VistRad subroutines for RPC calls[ 2/21/97  10:53 AM ] ; 22 Mar 2001  2:24 PM
- ;;3.0;IMAGING;**18,65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**18,65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -40,6 +40,5 @@
  . I STIEN S T=$O(^MAG(2005,STIEN,205,0)) I T S KEY=1
  S IRPT=0 F  S IRPT=$O(^RARPT(RARPT,2005,IRPT)) Q:'IRPT  S MAGIEN=$P(^(IRPT,0),U) D
- . Q:'$D(^MAG(2005,MAGIEN,0))
- . I MAGDT="" S MAGDT=$P($G(^MAG(2005,MAGIEN,100)),U,6) S:MAGDT="" MAGDT=$P($G(^(2)),U)
+ . Q:'$D(^MAG(2005,MAGIEN,0))  I MAGDT="" S MAGDT=$P($G(^(2)),U)
  . I $O(^MAG(2005,MAGIEN,1,0)) S CT=CT+$P(^(0),U,4),Y=$P(^(0),U,3),MAGIEN2=$P($G(^(Y,0)),U) S:(MAGIEN2]"") ONLCHK=$$ONLCHK(MAGIEN2),REMCHK=$$REMOTE(MAGIEN2) ; last image in group
  . E  S CT=CT+1,ONLCHK=$$ONLCHK(MAGIEN),REMCHK=$$REMOTE(MAGIEN)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL3.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL3.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL3.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJUTL3 ;WIRMFO/JHC VistARad subrtns & RPCs ; 29 Jul 2003  10:03 AM
- ;;3.0;IMAGING;**16,9,22,18,65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**16,9,22,18,65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -137,6 +137,5 @@
  I $G(MAGJOB("VRVERSION")) S X=MAGJOB("VRVERSION")
  E  S X="" ; non-client processes assume post-P32 logic
- S MAGJOB("P32")=(X="3.0.41.17") ; P32 Client?
- I MAGJOB("P32") D P32STOP^MAGJUTL5(.X) S MAGJOB("P32STOP")=X  ; STOP support when P76 releases
+ S MAGJOB("P32")=(X="3.0.41.17") ; support back-compatible P32 Client
  D USERKEYS
  S MAGJOB("CONSOLIDATED")=($G(^MAG(2006.1,"CONSOLIDATED"))="YES")
@@ -171,8 +170,9 @@
  Q RSL
  ;
-USERKEYS ; Store Security Keys in MagJob
+USERKEYS ; Store VRad Security Keys in MagJob
+ ;
  N I,X,Y
- N MAGKS ; keys to send to XUS KEY CHECK
- N MAGKG ; returned
+ N MAGKS ; list of keys to send to XUS KEY CHECK
+ N MAGKG ; list returned
  K MAGJOB("KEYS")
  S X="MAGJ",I=0
@@ -184,4 +184,5 @@
  Q
  ;
+ Q
 PINF1(MAGGRY,MAGDFN) ;RPC Call MAGJ PT INFO -- Get pt info
  S X="ERR3^MAGJUTL3",@^%ZOSF("TRAP")
@@ -189,17 +190,16 @@
  Q
  ;
-USERINF2(MAGGRY,DATA) ; rpc: MAGJ USER2--get user info
- ; Input= unused ^ Client Vs ^ Client O/S Vs
- ; Reply=
- ; 0) = 1/0^code~Msg |  DUZ ^ NAME ^ INITIALS ^ REQFLAG
- ; 1)= Net UserName ^ PSW ^ UserType ^ SYSADMIN
- ;     1/0=Success/Fail flag for vs chk
- ;     code=4 if fail
- ;     Msg=Disp msg if fail
- ;     REQFLAG = 1/0 (Ena/Disa Requisition for non-rad staff)
- ;     UserType = 3: Staff R'ist; 2: Resident R'ist; 1: Rad Tech; 0: Non-Rad
- ;     SYSADMIN = 1/0 1=user has System User privileges
- ; 2:N)=Sec Keys
- ;  
+USERINF2(MAGGRY,DATA) ; rpc: MAGJ USER2 -- Return user info
+ ;  Input = unused ^ Client Vrad Vs ^ Client O/S Vs
+ ;  Reply = 
+ ;  (0) = 1/0^code~Msg |  DUZ ^ NAME ^ INITIALS ^ REQ_FLAG
+ ;  (1)= Net UserName ^ PSW ^ UserType ^ SYSADMIN
+ ;      1/0=Success/Failure flag for vs compatibility
+ ;      code=4 if failure condition
+ ;      Msg=Display msg if failure condition
+ ;      REQ_FLAG = 1/0 (Enable/Disable Requisition for non-rad staff)
+ ;      UserType = 3: Staff R'ist; 2: Resident R'ist; 1: Rad Tech; 0: Non-Rad
+ ;      SYSADMIN = 1/0 1=user has Vrad System User privileges
+ ;
  S X="ERR2^MAGJUTL3",@^%ZOSF("TRAP")
  K MAGGRY S MAGGRY(0)="",MAGGRY(1)=""
@@ -225,6 +225,4 @@
  S X=+MAGJOB("USER",1),X=$S(X=15:3,X=12:2,+RADTECH:1,1:0)
  S MAGGRY(1)=MAGGRY(1)_U_X_U_$D(MAGJOB("KEYS","MAGJ SYSTEM USER"))
- S MAGGRY(2)="*KEYS",X="" F I=3:1 S X=$O(MAGJOB("KEYS",X)) Q:X=""  S MAGGRY(I)=X
- S MAGGRY(I)="*END"
 USERIN2Z Q
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL4.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL4.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL4.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGJUTL4 ;WIRMFO/JHC VistARad subroutines for RPC calls ; 15 Jul 2004  4:34 PM
- ;;3.0;IMAGING;**18,76**;Jun 22, 2007;Build 19
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**18**;Mar 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -66,5 +65,5 @@
  S IEN=0 F  S IEN=$O(RET(IEN)) Q:'IEN  D
  . N LIN S X=$G(@CPTGLB@(IEN,0))
- . Q:'(X]"")  S TCPT=$P(X,U),LIN=TCPT_U_$P($$CPT^ICPTCOD(TCPT),U,3) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~")
+ . Q:'(X]"")  S TCPT=$P(X,U),LIN=TCPT_U_$P($G(^ICPT(TCPT,0)),U,2) ; _U_$$BODPART(IEN,"~")_U_$$MDLLST(IEN,"~")
  . S CT=CT+1,@MAGGRY@(CT)=LIN
  S REPLY=CT_U_"1~ "_CT_" CPT Matches returned for "_CPTIN
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL5.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGJUTL5.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGJUTL5.m	(revision 636)
@@ -1,4 +1,4 @@
 MAGJUTL5 ;WOIFO/JHC - VistARad RPCs ; [ 07/3/2006 17:17 ]
- ;;3.0;IMAGING;**65,76**;Jun 22, 2007;Build 19
+ ;;3.0;IMAGING;**65**;Jul 27, 2006;Build 28
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;; +---------------------------------------------------------------+
@@ -24,7 +24,7 @@
  ; released Client will have the T version that the server expects
  ;
- S SVRVER="3.0.76",SVRTVER=14  ; <*> Edit this line for each patch/T-version
+ S SVRVER="3.0.65",SVRTVER=12  ; <*> Edit this line for each patch/T-version
  ;
- S ALLOWCL="|3.0.65|"  ;
+ S ALLOWCL="|3.0.18|"  ; note--patch 32 is numbered funny, so is hard-coded below
  Q
  ;
@@ -68,8 +68,14 @@
  S SVERSION=SV
  I TESTFLAG S SVERSION=SV_"."_ST
- ; Check Version differences:
+ ;
+ ; Patch 32 client is OK:
+ I CLVER="3.0.41.17" S MAGRY="1^1~P32 Client Version Check OK. Server: "_SVERSION_" Client: "_CLVER Q
+ ; Other Version differences:
  I (CV'=SV) D  Q
  . I '(ALLOWV[("|"_CV_"|")) D  Q
  . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_".  Contact Imaging support. (CNA)"
+ . ; Don't allow Test versions of P18
+ . I CP=18,(CT'=132) D  Q
+ . . S MAGRY="0^4~VistARad Workstation software version "_CLVER_" is not compatible with the VistA server version "_SVERSION_".  Contact Imaging support. (C18T)"
  . ; Warn the Client, allow to continue
  . I TESTFLAG S MAGRY="2^3~VistARad Workstation software version "_CLVER_" is running with VistA server TEST Version "_SVERSION_" --  VistARad will Continue, but contact Imaging Support if problems occur. (Pdif)"
@@ -89,16 +95,4 @@
  Q
  ;
-P32STOP(RET) ; logic to indicate P32 should no longer function, once the RELEASED P76 is installed
- ; This is invoked from magjutl3, P76 version, if a P32 client is launched
- ; RET=1/0 ^ text -- 0 = OK to run P32; 1 = Not OK
- N SV,ST,ALLOWV,SVSTAT,RELEASED
- S RET="0^P32 supported" ; init return to allow p32 to function
- D GETVER(.SV,.ST,.ALLOWV)
- D VERSTAT(.SVSTAT,SV)
- I 'SVSTAT S RET="0^Error, but on side of caution, allow running." Q  ; KIDS status for this version indeterminate
- S RELEASED=(+SVSTAT=2)
- I RELEASED!(SV'="3.0.76") S RET="1^P32 support over"  ; don't allow P32 to function
- Q
- ;
 VERSTAT(MAGRY,MAGVER) ;
  ; Returns the status of an Imaging Version
@@ -109,5 +103,5 @@
  N VERI,TVER,MAGERR
  I +MAGVER S MAGVER="MAG*"_$P(MAGVER,".",1,2)_"*"_$P(MAGVER,".",3)
- S VERI=$$FIND1^DIC(9.6,"","O",MAGVER,"","","MAGERR")
+ S VERI=$$FIND1^DIC(9.6,"","",MAGVER,"","","MAGERR")
  I 'VERI S MAGRY="0^4~There is No KIDs Install record."
  E  D
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGLOG.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGLOG.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGLOG.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGLOG ;WOIFO/RED,SRR,MLH - Log image access ; [ 06/20/2001 08:57 ]
- ;;3.0;IMAGING;**17,8,20,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**17,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -39,10 +38,7 @@
  I $D(MAGAD) S ^MAG(2006.95,MAGC,100)=MAGAD
  S ^MAG(2006.95,"B",MAGC,MAGC)=""
- D ACCESS(MAGO) ; This should be here.  Can now search 2006.95 from "Last Access Date" to "Capture Date" to
- ; get all Actions logged. We Don't have to search entire Image File.
  I $G(MAGJOB("SESSION")) S ^MAG(2006.95,"AS",+$G(MAGJOB("SESSION")),MAGC)=""
  Q
 ACCESS(MAGO) ; Update Field "Last Access Date" in Image File.
- Q:'$G(MAGO)
  I '$D(^MAG(2005,MAGO,0)) D  Q
  . I $D(^MAG(2005.1,MAGO,0)) S $P(^MAG(2005.1,MAGO,0),"^",9)=$$NOW^XLFDT
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBPG1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBPG1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBPG1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBPG1 ;WOIFO/RMP - REMOTE Task SERVER Program [ 11/08/2001 17:18 ]
- ;;3.0;IMAGING;**7,8,20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -79,5 +79,5 @@
 CNP2(RESULT,IEN,START,STOP) ;[MAGQ JBSCN]
  S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- N FNAME,PIECE,ZNODE,NODE2,BNODE,BNAME,PTR,HASH,TEMP,ORDER,RDATE,PLACE,OFFLINE,PLACEOK,GL,END,ACQSITE
+ N FNAME,PIECE,ZNODE,NODE2,BNODE,BNAME,PTR,HASH,TEMP,ORDER,RDATE,PLACE,OFFLINE,PLACEOK,GL,END
  S (RESULT,GL)="",PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2))),(OFFLINE,PLACEOK)=0
  S:START="" START=$O(^MAG(2005,0)) S:STOP="" STOP=$O(^MAG(2005,"A"),-1)
@@ -91,8 +91,8 @@
  . Q
  S IEN=+IEN
- F  D SCAN^MAGQBPG1(.IEN,ORDER,.GL) D  Q:((('OFFLINE)&PLACEOK)!('IEN)!($P(RESULT,U,21)="DUPE")!'$G(ACQSITE))
+ F  D SCAN^MAGQBPG1(.IEN,ORDER,.GL) D  Q:((('OFFLINE)&PLACEOK)!('IEN)!($P(RESULT,U,21)="DUPE"))
  . Q:'IEN
- . S ZNODE=$G(@(GL_IEN_",0)")),ACQSITE=$P($G(@(GL_IEN_",100)")),U,3)
- . S PLACEOK=$S($$PLACE^MAGBAPI(+ACQSITE)=$$PLACE^MAGBAPI($G(DUZ(2))):1,1:"")
+ . S ZNODE=$G(@(GL_IEN_",0)"))
+ . S PLACEOK=$S($P($G(@(GL_IEN_",100)")),U,3)=$G(DUZ(2)):1,1:"")
  . I $P(ZNODE,U,2)'="" S OFFLINE=$$IMOFFLN^MAGFILEB($P(ZNODE,U,2))  ; Only check the offline status of image files
  . I ($D(^MAG(2005.1,IEN,0))&$D(^MAG(2005,IEN,0))) D  Q  ; Image is duplicated in the Archive file
@@ -133,6 +133,4 @@
  . I $D(@(GL_IEN_",""FBIG"")")),'$P(BNODE,U),'$P(BNODE,U,2) S $P(RESULT,U,22)="EMPTY_FBIG"
  . Q
- I '$P($G(@(GL_IEN_",100)")),U,3) S $P(RESULT,U,23)=-1 ;"NO ACQ SITE VALUE"
- ;
  I GL[("^MAG(2005.1,") S $P(RESULT,U,21)="ARCH"
  E  S $P(RESULT,U,12,17)=$$CHKIMG^MAGQBUT2(IEN)
@@ -187,5 +185,4 @@
  . D ^XMD
  . K ^TMP($J,"MAGQDFN")
- . K XMSUB
  . Q
  E  S CNT=CNT+1,^TMP($J,"MAGQDFN",CNT)=INPUT
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBPRG.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBPRG.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBPRG.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBPRG ;WOIOFO/RMP Magnetic Server Purge processes [ 06/29/2001 18:28 ]
- ;;3.0;IMAGING;**7,3,8,20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,3,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way  |
@@ -54,5 +54,5 @@
  ;        17 = Jukebox offline
  N FILEXT,IEN,SITEID,MAGXX,MAGFILE,MAGFILE1,MAGFILE2,PACS,RIEN,ZNODE
- N FILETYPE,CPTR,JBPTR,CPOK,BNODE,ALTPATH,NMSPC,PLACE,RDHOLD,XX
+ N FILETYPE,CPTR,JBPTR,CPOK,BNODE,ALTPATH,NMSPC,PLACE,RDHOLD
  S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
  S PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
@@ -84,5 +84,5 @@
  . E  S RESULT="1^^9^^^"_IEN
  . Q
- I PLACE'=$$PLACE^MAGBAPI(+$P($G(^MAG(2005,IEN,100)),U,3)) D  Q
+ I PLACE'=$$PLACE^MAGBAPI($P($G(^MAG(2005,IEN,100)),U,3)) D  Q
  . S RESULT="-3^^15" Q  ;Foreign Place
  S ZNODE=^MAG(2005,IEN,0)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBTM.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBTM.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBTM.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBTM ;WOIFO/RMP - REMOTE Task SERVER Program [ 03/25/2001 11:20 ]
- ;;3.0;IMAGING;**1,7,8,20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**1,7,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -18,8 +18,8 @@
  ;
 ENTRY(RESULT,WSTAT,PROCESS) ; RPC[MAGQ ABP]
- N X,SYSIEN,SYSNAME,NODE,INDX,CNT,PROC,%,QPTR,QCNT,VERS,EXEDATE,WSOS,PLACE,VOK
+ N X,SYSIEN,SYSNAME,NODE,INDX,CNT,PROC,%,QPTR,QCNT,VERS,EXEDATE,WSOS,PLACE
  D NOW^%DTC
  S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- S (SYSIEN,CNT)=0,SYSNAME="",PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2))),VOK=""
+ S (SYSIEN,CNT)=0,SYSNAME="",PLACE=$$PLACE^MAGBAPI(+$G(DUZ(2)))
  S $P(RESULT(0),U,6)=$D(^XUSEC("MAG SYSTEM",DUZ))
  Q:'$P(RESULT(0),U,6)
@@ -38,6 +38,5 @@
  S $P(^MAG(2006.8,SYSIEN,1),U,4)=WSOS
  S VERS=$P(VERS,".",1,2)_"P"_$P(VERS,".",3)
- D VOKR^MAGQBUT4(.VOK,VERS)
- Q:'$P(VOK,U)
+ Q:'$$VOK^MAGQBUT4(VERS)
  S ^TMP("MAGQN",$J,0)=SYSIEN_"^"_WSTAT
  S NODE=^MAG(2006.8,SYSIEN,0)
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBUT1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBUT1 ;WOIFO/RP; Utilities for Background [ 03/25/2001 11:20 ]
- ;;3.0;IMAGING;**7,8,20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -180,5 +180,5 @@
  F INC=FROM:1:TO D
  . I ('$D(^MAG(2005,INC,0))&('$D(^MAG(2005.1,INC,0)))) Q
- . I ($$PLACE^MAGBAPI(+$P($G(^MAG(2005,INC,100)),U,3))'=PLACE)&($$PLACE^MAGBAPI(+$P($G(^MAG(2005.1,INC,100)),U,3)'=PLACE)) Q
+ . I ($P($G(^MAG(2005,INC,100)),U,3)'=INST)&($P($G(^MAG(2005.1,INC,100)),U,3)'=INST) Q
  . I ($P($G(^MAG(2005,INC,0)),"^",2)="")&($P($G(^MAG(2005.1,INC,0)),"^",2)="") Q  ;No full filename attribute
  . I (+$P($G(^MAG(2005,INC,1,0)),"^",4)>0)!(+$P($G(^MAG(2005.1,INC,1,0)),"^",4)>0) Q  ;GROUP PARENT
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT2.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBUT2.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT2.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBUT2 ;WOIFO/SRR/RMP -IMAGE SITE PARAMETERS COMPANION [ 11/08/2001 17:18 ]
- ;;3.0;IMAGING;**7,8,20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -16,6 +16,37 @@
  ;; +---------------------------------------------------------------+
  ;;
+VSTAV() ;
+ N VER,IEN,ARRAY,VALUE,LATEST
+ S VER=$$VERSION^XPDUTL("IMAGING")
+ S:$T(LAST^XPDUTL)]"" VER=VER_"^"_$$LAST^XPDUTL("IMAGING",VER)
+ Q VER
+IWSV(WSD,WSC,WSV,PLACE) ;IMAGE WORKSTATION VERSIONS
+ N IEN,NODE,RD,OS
+ S RD=$$FMADD^XLFDT($$NOW^XLFDT,-180,"","","")
+ S IEN=0
+ F  S IEN=$O(^MAG(2006.81,"C",PLACE,IEN)) Q:IEN'?1N.N  D
+ . S NODE=^MAG(2006.81,IEN,0)
+ . Q:($P(NODE,U,3)<RD)
+ . S OS=$P($G(^MAG(2006.81,IEN,1)),U,2)
+ . I $P(NODE,"^",9)'="" D
+ . . S INDEX=$P(NODE,"^",9),INDEX=$S(OS="":INDEX,1:INDEX_U_OS)
+ . . S WSD(INDEX)=$G(WSD(INDEX))+1
+ . I $P(NODE,"^",13)'="" D
+ . . S INDEX=$P(NODE,"^",13),INDEX=$S(OS="":INDEX,1:INDEX_U_OS)
+ . . S WSC(INDEX)=$G(WSC(INDEX))+1
+ . I $P(NODE,"^",15)'="" D
+ . . S INDEX=$P(NODE,"^",15),INDEX=$S(OS="":INDEX,1:INDEX_U_OS)
+ . . S WSV(INDEX)=$G(WSV(INDEX))+1
+ Q
+DICOMV(DCMG) ;Version of DICOM
+ N X,ARRAY,IEN,NAME
+ S X=""
+ F  S X=$O(^MAG(2006.83,"B",X)) Q:X=""  D
+ . S IEN=$O(^MAG(2006.83,"B",X,"")) Q:IEN'?1N.N
+ . S DCMG($P(^MAG(2006.83,IEN,0),U,3))=$G(DCMG($P(^MAG(2006.83,IEN,0),U,3)))+1
+ Q $S($D(DCMG):1,1:0)
+VISTARV() ;
+ Q $$VERSION^XPDUTL("MAGJ RADIOLOGY")
 MAGSYS(LIST) ;
- ; RPC[MAGQ SYSTEM]
  N VAIEN,NODE,MGIEN,UNAME,TDATE
  S MGIEN=$$FIND1^DIC(3.8,"","MX","MAG SERVER","","","ERR")
@@ -31,5 +62,5 @@
  . S LIST(VAIEN)=VAIEN_"^"_UNAME
  Q
-IMPAR(RESULT,QIEN) ; Import Array
+IMPAR(RESULT,QIEN) ;
  N INDX,CNT
  S (INDX,CNT)=0
@@ -40,4 +71,11 @@
  E  S RESULT(0)="1"
  Q
+SNS(PLACE) ;
+ N RESULT,INDEX
+ S INDEX=0
+ S RESULT=$P(^MAG(2006.1,PLACE,0),U,2)
+ F  S INDEX=$O(^MAG(2006.1,PLACE,4,INDEX)) Q:INDEX'?1N.N  D
+ . S RESULT=RESULT_U_$P($G(^MAG(2006.1,PLACE,4,INDEX,0)),U)
+ Q RESULT
 CHKIMG(IEN) ;
  ; Given an Image IEN, return:
@@ -84,10 +122,9 @@
  S IDFN=$P(X0,"^",7),$P(R,"^",4)=IDFN
  S PT(3.9)="^XMB(3.9,PD0,|Mail message||2|^XMB(3.9,PD0,2005,|MAIL"
- ; The following 5 Lab subsections must be in-synch with FILE+42^MAGGTLB1
  S PT(63)="^LR(PD0,GF,PD1,|Autopsy (microscopic)|AY|1|^LR(PD0,GF,PD1,2005,|AUM"
  S PT(63.02)="^LR(PD0,GF,PD1,|Electron microscopy|EM|1|^LR(PD0,GF,PD1,2005,|EM"
  S PT(63.08)="^LR(PD0,GF,PD1,|Surgical pathology|SP|1|^LR(PD0,GF,PD1,2005,|SP"
  S PT(63.09)="^LR(PD0,GF,PD1,|Cytology|CY|1|^LR(PD0,GF,PD1,2005,|CY|"
- S PT(63.2)="^LR(PD0,GF,PD1,|Autopsy (gross)|AY|1|^LR(PD0,GF,PD1,2005,|AUG"
+ S PT(63.2)="^LR(PD0,GF,PD1,|Autopsy (gross)|AU|1|^LR(PD0,GF,PD1,2005,|AUG"
  S PT(70)="^RADPT(PDFN,|Radiology Patient||1|"
  S PT(74)="^RARPT(PD0,|Radiology||2|^RARPT(PD0,2005,|RAD"
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT4.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBUT4.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT4.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBUT4 ;WOIFO/RMP - BP Utilities  ;19 Nov 2001 1:23 PM
- ;;3.0;IMAGING;**7,8,48,20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**7,8,48,20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -83,13 +83,13 @@
  . Q
  Q
- ;
-VOKR(RESULT,VER) ; RPC for VOK [MAGQ VOK]
- N CVERS,PNUM,SLINE
- S X="ERR^MAGQBTM",@^%ZOSF("TRAP")
- S SLINE=$T(+2)
+VOK(VER) ; Check for the appropriate BP Queue processor version
+ ; This routine MAGQBUT4 will need to be released with each BP Update
+ ; The variable CVERS will contain the current BP server version
+ ;       ;;3.0;IMAGING;**7,13,8**;Jul 26, 2004
+ N VN,I,CVERS,PNUM,SLINE,ALTVER
+ S SLINE=$T(+2),ALTVER=","_$$TRIM($P(SLINE,"**",2))_","
  S PNUM=$$TRIM($P(SLINE,"**",2)),PNUM=$$TRIM($P(PNUM,",",$L(PNUM,",")))
  S CVERS=$$TRIM($P(SLINE,";",3))_"P"_PNUM
- S RESULT=$S(CVERS=VER:1,1:0)_U_CVERS
- Q
+ Q $S(CVERS=VER:1,$P(VER,"P",2)["13":1,ALTVER[(","_$P(VER,"P",2)_","):1,1:0)
  ;
 TRIM(X) ; remove both leading and trailing blanks
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT5.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGQBUT5.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGQBUT5.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGQBUT5 ;WOIFO/RMP - BP Utilities  ;Oct 21, 2005 1:23 PM
- ;;3.0;IMAGING;**20,81**;May 17, 2007
- ;;  Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**20**;Apr 12, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed             |
@@ -66,21 +66,3 @@
  D MAILSHR^MAGQBUT1
  Q
-RMRPC(NAME) ; Removing an RPC in order to revise
- N MW,RPC,MWE,DIERR
- S MW=$$FIND1^DIC(19,"","X","MAG WINDOWS","","","")
- D CLEAN^DILF
- Q:'MW
- S RPC=$$FIND1^DIC(8994,"","X",NAME,"","","")
- D CLEAN^DILF
- Q:'RPC
- S MWE=$$FIND1^DIC(19.05,","_MW_",","X",NAME,"","","")
- D CLEAN^DILF
- Q:'MWE
- S DA=MWE,DA(1)=MW,DIK="^DIC(19,"_DA(1)_",""RPC"","
- D ^DIK
- K DA,DIK
- S DA=RPC,DIK="^XWB(8994,"
- D ^DIK
- K DA,DIK
- Q
  ;
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGSIXG1.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGSIXG1.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGSIXG1.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGSIXG1 ;WOIFO/EdM/GEK/SEB - RPCs for Document Imaging ; 04/29/2002  16:15
- ;;3.0;IMAGING;**8,48,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8,48**;Jan 11, 2005
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -19,26 +18,13 @@
  Q
  ;
- ; OUT  =  Output array.  
- ;   OUT(0)        ->  1|0 ^ message
- ;   OUT(1)        ->  Field Headers 
- ;       '^' delimited list of column headers used in cMagListView
- ;   OUT(2..n) ->  each line is information on 1 image.
- ;       piece '|' 1 is '^' delimited data to be displayed in columns.
- ;       piece '|' 2  is data that is used internally by App.
- ;       
- ; PKG   - Package fld 40
- ; CLS   - Class   fld 41
- ; TYPE  - Type    fld 42
- ; EVENT - Proc/Event         fld 43
- ; SPEC  - Spec/SubSpecialty  fld 44
- ; FROM  - Date to search from
- ; UNTIL - Date to search to
- ; ORIGIN - Origin fld 45
- ; DATA  -  Future
- ; FLGS  -  Future  
- ; 
-PGI(OUT,DFN,PKG,CLS,TYPE,EVENT,SPEC,FROM,UNTIL,ORIGIN,DATA,FLGS) ;RPC [MAG4 PAT GET IMAGES]
+ ; OUT ;--- Output array
+ ; CLS ;--- Class
+ ; TYPE ;-- Type (of what?)
+ ; SPEC ;-- Specialty or SubSpecialty
+ ; EVENT ;- Event or Procedure or Action
+PGI(OUT,DFN,PKG,CLS,TYPE,EVENT,SPEC,FROM,UNTIL,ORIGIN) ;RPC [MAG4 PAT GET IMAGES]
  ; Get Images for Patient.  
  ; New call in Patch 3.0.8 uses Image Filter to get list of images
+ ; 
  N C,DAT1,DAT2,E,IMAGE,N,OK,P,RDT,RESULT,S,T,V,CT,PKG1,CLS1,TYPE1,EVENT1,SPEC1,FLTX,FLTY,CAPDUZ,CAPDT,MAGVR,FNL
  S FROM=$G(FROM),UNTIL=$G(UNTIL)
@@ -56,79 +42,64 @@
  S N=0
  D NETPLCS^MAGGTU6
+ ;S RDT="" F  S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:RDT=""  D
  ;3.0.8/gek, Quit searching all images, just do the date range.
  S RDT=DAT1 F  S RDT=$O(^MAG(2005,"APDTPX",DFN,RDT)) Q:(RDT="")!(RDT>DAT2)  D
- . K ^TMP($J,"MAGSIX")
  . N COUNT,PRX,X0,X2,X40,I1,X01
- . S PRX="" F  S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX=""  M ^TMP($J,"MAGSIX")=^MAG(2005,"APDTPX",DFN,RDT,PRX)
- . S IMAGE="" F  S IMAGE=$O(^TMP($J,"MAGSIX",IMAGE),-1) Q:IMAGE=""  D
- . . S X0=$G(^MAG(2005,IMAGE,0))
- . . Q:$P(X0,"^",10)  ; child of Group
- . . S X2=$G(^MAG(2005,IMAGE,2)),X40=$G(^MAG(2005,IMAGE,40)),I1=$O(^MAG(2005,IMAGE,1,0))
- . . S P=$P(X40,U),C=$P(X40,"^",2),T=$P(X40,"^",3),E=$P(X40,"^",4),S=$P(X40,"^",5)
- . . ;Patch 59.  Treat Class as a computed Field.  Arrange with Mike to change DB.
- . . S C=$S('T:"",'$D(^MAG(2005.83,T,0)):"",1:$P(^(0),"^",2))
- . . S V=$S($P(X40,"^",6)="":"V",1:$P(X40,"^",6)) ; P48T1 show VA for Null
- . . D CHK^DIE(2005,45,"E",V,.MAGVR) I MAGVR'="^" S V=MAGVR(0) ; P48T1 show External Value
- . . I PKG'="",P'="",'$D(OK(5,P)) Q
- . . I ORIGIN'="",V'="",'$D(OK(6,V)) Q
- . . I CLS'="",C'="",'$D(OK(1,C)) Q
- . . I EVENT'="",E,'$D(OK(2,E)) Q
- . . ;3.0.8 Stop list entries with no Event, if Event is in Search Specs
- . . I EVENT'="",E="" Q
- . . I SPEC'="",S,'$D(OK(3,S)) Q
- . . ;3.0.8 Stop list entries with no Spec, if Spec is in Search Specs
- . . I SPEC'="",S="" Q
- . . I TYPE'="",T,'$D(OK(4,T)) Q
- . . ; Get Count of Images in Group, use 4th piece of ,1,0) multiple
- . . S COUNT=$S($P($G(^MAG(2005,IMAGE,1,0)),"^",4):$P($G(^MAG(2005,IMAGE,1,0)),"^",4),1:1)
- . . S FLTX=""
- . . ; PUT in Site Code as 2nd piece.
- . . S X01=$S(I1:$G(^MAG(2005,+$G(^MAG(2005,IMAGE,1,I1,0)),0)),1:X0)
- . . S FNL=$S(+$P(X01,"^",3):$P(X01,"^",3),1:+$P(X01,"^",5))
- . . S FLTX=$P($G(MAGJOB("NETPLC",FNL)),"^",2)
- . . I FLTX="" S FLTX=$G(MAGJOB("PLCODE"))
- . . S FLTX=FLTX_"^"_$$RPTITLE($P(X2,"^",6),$P(X2,"^",7))
- . . S X=$$FMTE^XLFDT($P(X2,"^",5),"5Z")
- . . S X=$P(X,"@",1)_" "_$S($L($P(X,"@",2)):$P(X,"@",2),1:"00:01")
- . . S FLTX=FLTX_"^"_X
- . . S FLTX=FLTX_"^"_$P(X0,"^",8)_"^"_COUNT_"^"_$P(X2,"^",4)
- . . S FLTX=FLTX_"^"_P
- . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.82,+C,0)),"^",1)
- . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.83,+T,0)),"^",1)
- . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.84,+S,0)),"^",1)
- . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.85,+E,0)),"^",1)
- . . S FLTX=FLTX_"^"_V
- . . ;S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",1),"5Z"),"@",1)
- . . S X=$$FMTE^XLFDT($P(X2,"^",1),"5Z")
- . . S X=$P(X,"@",1)_" "_$S($L($P(X,"@",2)):$P(X,"@",2),1:"00:01")
- . . S FLTX=FLTX_"^"_X
- . . ;;;;;;;;;
- . . ; P8T36 gek. Fix Error caused if $P(X2,"^",2) "ImageSavedBy" is null
- . . S FLTX=FLTX_"^"_$$GET1^DIQ(200,+$P(X2,"^",2)_",",.01)
- . . N MAGFILE,MAGXX
- . . S MAGXX=IMAGE D INFO^MAGGTII
- . . S FLTX=FLTX_"^"_$P(MAGFILE,"^",1)
- . . S N=N+1,@RESULT@(N+1)=N_"^"_FLTX_"|"_MAGFILE
- . . Q:N<76  Q:RESULT["^"
- . . ; Image count is getting big, switch from array to Global return type
- . . S ^TMP($T(+0),$J)=""
- . . M ^TMP($T(+0),$J)=OUT
- . . K OUT
- . . S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1)
- . . S RESULT=$NA(^TMP($T(+0),$J))
- . . S OUT=$NA(^TMP($T(+0),$J)) ;GEK 10/01/02
+ . S PRX="" F  S PRX=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX)) Q:PRX=""  D
+ . . S IMAGE="" F  S IMAGE=$O(^MAG(2005,"APDTPX",DFN,RDT,PRX,IMAGE)) Q:IMAGE=""  D
+ . . . S X0=$G(^MAG(2005,IMAGE,0))
+ . . . Q:$P(X0,"^",10)  ; child of Group
+ . . . S X2=$G(^MAG(2005,IMAGE,2)),X40=$G(^MAG(2005,IMAGE,40)),I1=$O(^MAG(2005,IMAGE,1,0))
+ . . . S P=$P(X40,U),C=$P(X40,"^",2),T=$P(X40,"^",3),E=$P(X40,"^",4),S=$P(X40,"^",5)
+ . . . S V=$S($P(X40,"^",6)="":"V",1:$P(X40,"^",6)) ; P48T1 show VA for Null
+ . . . D CHK^DIE(2005,45,"E",V,.MAGVR) S V=MAGVR(0) ; P48T1 show External Value
+ . . . I PKG'="",P'="",'$D(OK(5,P)) Q
+ . . . I ORIGIN'="",V'="",'$D(OK(6,V)) Q
+ . . . I CLS'="",C'="",'$D(OK(1,C)) Q
+ . . . I EVENT'="",E,'$D(OK(2,E)) Q
+ . . . ;3.0.8 Stop list entries with no Event, if Event is in Search Specs
+ . . . I EVENT'="",E="" Q
+ . . . I SPEC'="",S,'$D(OK(3,S)) Q
+ . . . ;3.0.8 Stop list entries with no Spec, if Spec is in Search Specs
+ . . . I SPEC'="",S="" Q
+ . . . I TYPE'="",T,'$D(OK(4,T)) Q
+ . . . ; Get Count of Images in Group, use 4th piece of ,1,0) multiple
+ . . . S COUNT=$S($P($G(^MAG(2005,IMAGE,1,0)),"^",4):$P($G(^MAG(2005,IMAGE,1,0)),"^",4),1:1)
+ . . . S FLTX=""
+ . . . ; PUT in Site Code as 2nd piece.
+ . . . S X01=$S(I1:$G(^MAG(2005,+$G(^MAG(2005,IMAGE,1,I1,0)),0)),1:X0)
+ . . . S FNL=$S(+$P(X01,"^",3):$P(X01,"^",3),1:+$P(X01,"^",5))
+ . . . S FLTX=$P($G(MAGJOB("NETPLC",FNL)),"^",2)
+ . . . S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",5),"5Z"),"@",1)
+ . . . S FLTX=FLTX_"^"_$P(X0,"^",8)_"^"_COUNT_"^"_$P(X2,"^",4)
+ . . . S FLTX=FLTX_"^"_P
+ . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.82,+C,0)),"^",1)
+ . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.83,+T,0)),"^",1)
+ . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.84,+S,0)),"^",1)
+ . . . S FLTX=FLTX_"^"_$P($G(^MAG(2005.85,+E,0)),"^",1)
+ . . . S FLTX=FLTX_"^"_V
+ . . . S FLTX=FLTX_"^"_$P($$FMTE^XLFDT($P(X2,"^",1),"5Z"),"@",1)
+ . . . ; P8T36 gek. Fix Error caused if $P(X2,"^",2) "ImageSavedBy" is null
+ . . . S FLTX=FLTX_"^"_$$GET1^DIQ(200,+$P(X2,"^",2)_",",.01)
+ . . . N MAGFILE,MAGXX
+ . . . S MAGXX=IMAGE D INFO^MAGGTII
+ . . . S FLTX=FLTX_"^"_$P(MAGFILE,"^",1)
+ . . . S N=N+1,@RESULT@(N+1)=N_"^"_FLTX_"|"_MAGFILE
+ . . . Q:N<101  Q:RESULT["^"
+ . . . ; Image count is getting big, switch from array to Global return type
+ . . . S ^TMP($T(+0),$J)=""
+ . . . M ^TMP($T(+0),$J)=OUT
+ . . . K OUT
+ . . . S X=$$RTRNFMT^XWBLIB("GLOBAL ARRAY",1)
+ . . . S RESULT=$NA(^TMP($T(+0),$J))
+ . . . S OUT=$NA(^TMP($T(+0),$J)) ;GEK 10/01/02
+ . . . Q
  . . Q
- . ;Q
  . Q
  S FLTY=$$FLTDESC(X)
  I 'N S @RESULT@(0)="0^No images for filter: "_FLTY  Q
  S @RESULT@(0)="1^"_FLTY
- S @RESULT@(1)="Item~S2^Site^Note Title~~W0^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0"
- ;S @RESULT@(1)="Item~S2^Site^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0"
+ S @RESULT@(1)="Item~S2^Site^Proc DT~S1^Procedure^# Img~S2^Short Desc^Pkg^Class^Type^Specialty^Event^Origin^Cap Dt~S1~W0^Cap by~~W0^Image ID~S2~W0"
  Q
-RPTITLE(FILE,IEN) ; 
- I FILE=8925,$D(^TIU(8925,IEN,0)) Q $P(^TIU(8925.1,$P(^TIU(8925,IEN,0),"^",1),0),"^",1)
- ;I FILE=8925,$D(^TIU(8925,IEN,0)) Q $$GET1^DIQ(FILE,IEN,".01:.01")
- E  Q "   "
 FLTDESC(X) ;
  N FLT
@@ -153,5 +124,5 @@
  . S $P(EVENT,",",CT)=$E(EVENT1)_$$LOW^XLFSTR($E(EVENT1,2,999))
  S FLT=FLT_$S(EVENT="":"",1:"Event: "_EVENT_" - ")
- ; Origin
+ ; Orgin
  S FLT=FLT_$S(ORIGIN="":"",1:"Origin: "_ORIGIN_" - ")
  ; Date Range - From
Index: FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGSIXGT.m
===================================================================
--- FOIAVistA/trunk/r/IMAGING-MAG-ZMAG/MAGSIXGT.m	(revision 631)
+++ FOIAVistA/tag/r/IMAGING-MAG-ZMAG/MAGSIXGT.m	(revision 636)
@@ -1,5 +1,4 @@
 MAGSIXGT ;WOIFO/EdM/GEK/SEB - RPC for Document Imaging ; 04/29/2002  16:15
- ;;3.0;IMAGING;**8,48,61,59**;Nov 27, 2007;Build 20
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;IMAGING;**8,48,61**;Feb 07, 2006
  ;; +---------------------------------------------------------------+
  ;; | Property of the US Government.                                |
@@ -9,4 +8,5 @@
  ;; | Development Office of the Department of Veterans Affairs,     |
  ;; | telephone (301) 734-0100.                                     |
+ ;; |                                                               |
  ;; | The Food and Drug Administration classifies this software as  |
  ;; | a medical device.  As such, it may not be changed in any way. |
@@ -29,5 +29,5 @@
  N MAGX
  K OUT
- S CLS=$G(CLS),FLGS=$P($G(FLGS),"|")
+ S CLS=$G(CLS),FLGS=$G(FLGS)
  ; Capture app will send CLS as ADMIN,ADMIN/CLIN for admin
  ; or  CLIN,CLIN/ADMIN for clinical 
@@ -69,5 +69,5 @@
  N C,D0,D1,LOC,N,NO,OK,S,X,NODE
  K OUT
- S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$P($G(FLGS),"|")
+ S CLS=$G(CLS),SPEC=$G(SPEC),FLGS=$G(FLGS)
  S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3)
  D CLS Q:$D(OUT(0))
@@ -116,5 +116,5 @@
  N C,D0,D1,E,LOC,N,OK,X
  K OUT
- S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$P($G(FLGS),"|")
+ S CLS=$G(CLS),EVENT=$G(EVENT),FLGS=$G(FLGS)
  S IGN=$P(FLGS,"^",1),INCL=$P(FLGS,"^",2),INST=$P(FLGS,"^",3),INSP=$P(FLGS,"^",4)
  I CLS'="" D CLS Q:$D(OUT(0))
Index: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m
===================================================================
--- FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m	(revision 631)
+++ FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m	(revision 636)
@@ -1,4 +1,4 @@
 IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 04/23/03 1:43pm
- ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74,123**;21-OCT-94;Build 6
+ ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74**;21-OCT-94
  ;
  ;
@@ -142,7 +142,5 @@
  .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22)
  .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1)
- .; Check that test is for same year
- .I $P(IVMLAST,U,2),$E($P(IVMLAST,U,2),1,3)'=$E(IVMMTDT,1,3) S IVMLAST=""
- .I $$Z06MT^EASPTRN1(+IVMLAST) D PROB^IVMCMC("IVM Means Test already on file for this year") Q
+ .I $$Z06MT^EASPTRN1(+IVMLAST) Q
  .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient"
  .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D
Index: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m
===================================================================
--- FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m	(revision 631)
+++ FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ07C.m	(revision 636)
@@ -1,4 +1,4 @@
-IVMZ07C ;BAJ/PHH - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 1/17/2008
- ;;2.0;INCOME VERIFICATION MATCH;**105,128**;JUL 8,1996;Build 2
+IVMZ07C ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- DRIVER ROUTINE ; 9/27/2006
+ ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
  ;
  ; 
@@ -100,5 +100,6 @@
  S DTTM=$O(^DGMS(29.11,"APDT",DFN,""),-1)
  I DTTM'="" D
- . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,""),-1)
+ . S DTTM=$O(^DGMS(29.11,"APDT",DFN,""))
+ . S NIEN=$O(^DGMS(29.11,"APDT",DFN,DTTM,""))
  . I $D(^DGMS(29.11,NIEN,0)) S DGP("MST",0)=^DGMS(29.11,NIEN,0)
  ;
Index: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m
===================================================================
--- FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m	(revision 631)
+++ FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CD.m	(revision 636)
@@ -1,4 +1,4 @@
-IVMZ7CD ;CKN,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006
- ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
+IVMZ7CD ;CKN,BAJ - HL7 Z07 CONSISTENCY CHECKER -- DEMOGRAPHIC SUBROUTINE ; 9/27/2006
+ ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
  ;
  ; Demographic Consistency Checks
@@ -69,5 +69,5 @@
  Q
  ;
-306 ; VALID SSN/PSEUDO SSN REQUIRED, turned off with DG*5.3*771
+306 ; VALID SSN/PSEUDO SSN REQUIRED
  N Z
  S X=$P($G(DGP("PAT",0)),U,9)
@@ -83,5 +83,5 @@
  Q
  ;
-307 ; PSEUDO SSN REASON REQUIRED, turned off with DG*5.3*771
+307 ; PSEUDO SSN REASON REQUIRED
  S X=$P($G(DGP("PAT",0)),U,9)
  I X]"",X["P",$P($G(DGP("PAT","SSN")),U)="" S FILERR(RULE)=""
Index: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m
===================================================================
--- FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m	(revision 631)
+++ FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CE.m	(revision 636)
@@ -1,4 +1,4 @@
-IVMZ7CE ;TDM,BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 12/4/07 2:56pm
- ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
+IVMZ7CE ;TDM,BAJ - HL7 Z07 CONSISTENCY CHECKER -- SERVICE SUBROUTINE ; 01/23/07
+ ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
  ;
  ; Eligibility Consistency Checks
@@ -61,5 +61,4 @@
  ;
 409 ; AGREE TO PAY DEDUCT INVALID
- ; this CC inactivated by DG*5.3*771
  ; 2  PENDING ADJUDICATION     MEANS TEST
  ; 6  MT COPAY REQUIRED     MEANS TEST
Index: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m
===================================================================
--- FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m	(revision 631)
+++ FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMZ7CR.m	(revision 636)
@@ -1,4 +1,4 @@
-IVMZ7CR ;BAJ,ERC - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/6/07 8:51am
- ;;2.0;INCOME VERIFICATION MATCH;**105,127**;JUL 8,1996;Build 6
+IVMZ7CR ;BAJ - HL7 Z07 CONSISTENCY CHECKER -- REGISTRATION SUBROUTINE ; 12/7/05 12:24pm
+ ;;2.0;INCOME VERIFICATION MATCH;**105**;JUL 8,1996;Build 2
  ;
  ; Registration Consistency Checks
@@ -15,5 +15,5 @@
  S SPDEP=$D(DGSD("DEP"))
  ; we do not count through all numbers to save routine space
- F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,75,76,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D
+ F RULE=4,7,9,11,13,15,16,19,24,29:1:31,34,60,72,74,78,81,83,85,86 I $D(^DGIN(38.6,RULE)) D
  . I $$ON(RULE) D @RULE
  I $D(FILERR) M ^TMP($J,DFN)=FILERR
@@ -100,5 +100,5 @@
  I $P(DGP("PAT",.321),U,2)="Y",$P(DGP("PAT",.321),U,13)="" S FILERR(RULE)=""
  Q
-72 ; MSE DATA MISSING/INCOMPLETE, turned off with DG*5.3*765
+72 ; MSE DATA MISSING/INCOMPLETE
  ; Note: Rule #513 in IVMZ7CS is a duplicate of this rule.
  N I,X
@@ -109,11 +109,12 @@
  Q
  ;
-74 ; CONFLICT DT MISSING/INCOMPLETE, turned off with DG*5.3*765 
- ; Note:#515 IVMZ7CS is a duplicate, turned off with DG*5.3*771
-75 ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT
-76 ;      # 76 INACCURATE CONFLICT DATE, turned off with DG*5.3*771
+74 ; CONFLICT DT MISSING/INCOMPLETE
+ ; Note: Rule #515 in IVMZ7CS is a duplicate of this rule.
+ ; ALSO # 75 CONFLICT TO DT BEFORE FROM DT
+ ;      # 76 INACCURATE CONFLICT DATE
  ; 
- N I,T,FROM,TO,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON74,ON75,ON76
- S ON74=$$ON(74),ON75=$$ON(75),ON76=$$ON(76)
+ N I,T,FROM,TO,RULE1,RULE2,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON75,ON76
+ S RULE1=75,RULE2=76
+ S ON75=$$ON(75),ON76=$$ON(76)
  S I=$$RANGE^DGMSCK()    ; load range table
  F I=1:1 S CONFL=$P($T(CONLIST+I),";;",3) Q:CONFL="QUIT"  D
@@ -127,8 +128,8 @@
  . S FROM=$P(DGP("PAT",NODE),U,PCEFR),TO=$P(DGP("PAT",NODE),U,PCETO)
  . ; check rule 74 CONFLICT DT MISSING/INCOMPLETE
- . I ON74,(RULE=74) F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1
+ . F T=FROM,TO I '$$YM^IVMZ7CS(T) S FILERR(RULE)="",ERR=1
  . Q:ERR
  . ; check rule 75 CONFLICT TO DT BEFORE CONFLICT FROM DT
- . I ON75,(RULE=75),(FROM>TO) S FILERR(RULE)="",ERR=1
+ . I ON75,FROM>TO S FILERR(RULE1)="",ERR=1
  . Q:ERR
  . ; check rule 76 INACCURATE CONFLICT DATE
@@ -137,8 +138,8 @@
  . ; determine whether dates are withing conflict range
  . S RFR=$P(RANGE(RNGE),U,1),RTO=$P(RANGE(RNGE),U,2)
- . I ON76,(RULE=76) D
- . . I '((RFR'>FROM)&((RTO'<TO))) S FILERR(RULE)=""
- Q
-78 ; INACCURATE COMBAT DT/LOC, turned off with DG*5.3*771
+ . I ON76 D
+ . . I '((RFR'>FROM)&((RTO'<TO))) S FILERR(RULE2)=""
+ Q
+78 ; INACCURATE COMBAT DT/LOC
  N I,T,FROM,TO,RULE,NODE,PCE,PCEFR,PCETO,CONFL,RANGE,RFR,RTO,RNGE,ERR,COM,ON78,LOC
  ; This tag checks COMBAT status and verifies that valid FROM & TO dates are found
@@ -157,5 +158,5 @@
  . I '(RFR'>FROM&((FROM'>RTO)&((RTO'<TO)&((TO'<RFR))))) S FILERR(RULE)=""
  Q
-81 ; COMBAT DT NOT WITHIN MSE, turned off with DG*5.3*765
+81 ; COMBAT DT NOT WITHIN MSE
  ; this code is copied from DGRP3
  ; MSFROMTO^DGMSCK creates a block for a continual MSE
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGOEC.m	(revision 636)
@@ -1,4 +1,4 @@
 PSGOEC ;BIR/CML3-CANCEL ORDERS ;02 Mar 99 / 9:29 AM
- ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175,201**;16 DEC 97;Build 2
+ ;;5.0; INPATIENT MEDICATIONS ;**23,58,110,175**;16 DEC 97;Build 18
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191.
@@ -96,4 +96,5 @@
  N PROVIDER,PROVNAME,RESULT,RSB S RESULT=0
  S PROVIDER=+$P($G(^PS(55,DFN,5.1)),"^",2),PROVNAME=""
+ I $G(PSJRQPND) S PROVIDER=0
  I PROVIDER>0 D
  .S DIC=200,DR="53.1;53.4",DIQ="RSB",DIQ(0)="I",DA=PROVIDER D EN^DIQ1
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGPLR.m	(revision 636)
@@ -1,4 +1,4 @@
-PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ; 6/15/07 1:12pm
- ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129,191**;16 DEC 97;Build 9
+PSGPLR ;BIR/CML3-PRINTS PICK LIST REPORT ;04 May 98 / 11:23 AM
+ ;;5.0; INPATIENT MEDICATIONS ;**10,50,67,119,129**;16 DEC 97
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191.
@@ -31,10 +31,9 @@
  .N OSTOP,DRGND S (DDRG,OLDWARD)="" S DRGND=$O(PSGPLREN("B",PSGP,PSJJORD,0)) Q:'DRGND  S OSTOP=PSGPLREN("B",PSGP,PSJJORD,DRGND) Q:'OSTOP
  .N ST,TMPDRG S CNT=0,ST=$P(ND0,"^",7) S TMPDRG=0 S TMPDRG=$O(PSGPLREN("B",PSGP,PSJJORD,TMPDRG)) S TMPDRG=$P(DRG,"^")_"^"_TMPDRG
- .F PSGPLXRX="AU","AC" Q:CNT  F I=0:1 S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  D
+ .F PSGPLXRX="AU","AC" Q:CNT  F  S DDRG=$O(PSGPLREN(53.5,PSGPLXRX,PSGPLG,TM,WDN,RM,PN,PST,TMPDRG,DDRG)) Q:(DDRG="")!(DDRG="NO DISPENSE DRUG")  D
  ..S X=$G(PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND,1,$P(DDRG,"^",2),0)) S DR=+X,DND=$P(X,U,2,4) Q:'X
  ..S DRN=$G(^PS(55,PSGP,5,PSJJORD,1,DR,0)),DR=$$ENDDN^PSGMI($P(DRN,"^")) I DND?7N1"DI" S DND=$E($$ENDTC^PSGMI(+DND),1,8)
  ..S DIS=$P(DND,"^",2),NEED=$S($P(DND,"^")]"":$P(DND,"^"),1:0)
- ..;GMZ;PSJ*5*191;Allow for Multiple Dispensed Drug units needed
- ..S PSJRNW(I)=1_"^"_+NEED
+ ..S PSJRNW=1_"^"_+NEED
  ..Q
  .K PSGPLREN("B",PSGP,PSJJORD),PSGPLREN(53.5,PSGPLG,1,PSGP,1,+DRGND) W !!
@@ -47,7 +46,5 @@
  .I ATC S X=0,X=$O(^PS(59.7,X)) I $P($G(^(X,26)),U,2)=1,PST="OC" S ATC=0
  .S UD=$S('UD:1,UD=.5:"1/2",UD=.25:"1/4",UD<1:"0"_UD,1:UD)
- .I $D(PSJRNW) D
- ..I 'CNT W !?35,"**** RENEWAL ****"
- ..S NEED=NEED-$P(PSJRNW(CNT),"^",2) S:NEED<0 NEED=0 S CNT=CNT+1
+ .I $G(PSJRNW),'CNT W !?35,"**** RENEWAL ****" S CNT=CNT+1,NEED=NEED-$P(PSJRNW,"^",2) S:NEED<0 NEED=0
  .W !?6,DR,?48,ST W:(ATC)&(NEED>0) ?57,"ATC" W ?61,$J(UD,4),?68,$J(NEED,4),?75,$S(DIS]"":$J(DIS,4),1:"____")
  .S:ST="DISCONTINUED" OLDWARD=1 S ST=""
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGSICHK.m	(revision 636)
@@ -1,6 +1,5 @@
 PSGSICHK ;BIR/CML3-CHECKS SPECIAL INSTRUCTIONS ;17 Aug 98 / 8:33 AM
- ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175,201,185**;16 DEC 97;Build 6
+ ;;5.0; INPATIENT MEDICATIONS ;**3,9,26,29,44,49,59,110,139,146,160,175**;16 DEC 97;Build 18
  ;
- ; Reference to ^PS(50.605 is supported by DBIA 696.
  ; Reference to EN^PSOORDRG is supported by DBIA 2190.
  ; Reference to ^PSI(58.1 is supported by DBIA 2284.
@@ -12,6 +11,4 @@
  ; Reference to ^ORRDI1 is supported by DBIA 4659.
  ; Reference to ^XTMP("ORRDI" is supported by DBIA 4660.
- ; Reference to GETDATA^GMRAOR supported by DBIA 4847.
- ; Reference to ^TMP("GMRAOC" supported by DBIA 4848.
  ;
 START ;
@@ -28,13 +25,6 @@
 ENSET(X) ; expands the SPECIAL INSTRUCTIONS field contained in X into Y
  N X1,X2,Y S Y=""
- ;BHW;PSJ*5*185;Modified Logic below to NOT strip spaces and allow existing logic to flow.
- ;             ;Removed code I X2]"" Before Set of Y and created argumentless DO structure.
- F X1=1:1:$L(X," ") S X2=$P(X," ",X1) D
- . I X2']"" S Y=Y_" " Q  ;if multiple spaces in text and were $P'ing through text, X2 will="" so just add space and continue
- . S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
- . Q
- ;BHW;Modified stripping of spaces at end of string
- F X1=$L(Y):-1:0 Q:$E(Y,X1,X1)'=" "  S Y=$E(Y,1,X1-1)
- Q Y
+ F X1=1:1:$L(X," ") S X2=$P(X," ",X1) I X2]"" S Y=Y_$S($L(X2)>30:X2,'$D(^PS(51,+$O(^PS(51,"B",X2,0)),0)):X2,$P(^(0),"^",2)]""&$P(^(0),"^",4):$P(^(0),"^",2),1:X2)_" "
+ S Y=$E(Y,1,$L(Y)-1) Q Y
  ;
 END ; used by DRUG (55.06,101 & 53.1,101) x-refs to warn user if patient is receiving or about to receive the drug just ordered
@@ -58,4 +48,5 @@
  I $T(HAVEHDR^ORRDI1)]"",$$HAVEHDR^ORRDI1,'$D(^XTMP("ORRDI","OUTAGE INFO","DOWN")) D
  . I $P($G(^XTMP("ORRDI","PSOO",PSGP,0)),"^",3)<0 W !,"Remote data not available - Only local order checks processed." D PAUSE^PSJLMUT1
+ K ^TMP($J,"DUPDRG")  ;DEM - Duplicate Drug Check Ehancement.
  I $D(^TMP($J,"DD")) D ORDCHK^PSJLMUT1(PSGP,"DD",4)
  I $D(^TMP($J,"DC")) D ORDCHK^PSJLMUT1(PSGP,"DC",6)
@@ -63,4 +54,5 @@
  I '$D(PSJFST) N PSJFST S PSJFST=0
  I $D(^TMP($J,"DI")) S INTERVEN=1 D ORDCHK^PSJLMUT1(PSGP,"DI",8)
+ D DUPDRG^PSJLMUT2(PSGP) K ^TMP($J,"DUPDRG")  ;DEM - Duplicate Drug Check Ehancement.
  ;*** Allergy/adverse reaction check.
  N PTR,X
@@ -75,10 +67,17 @@
  .W !!
  K PSJACK,GMRAING,I,^TMP($J)
- D ALGCLASS
+ D ALGCLASS^PSGSICH1
 CONT ; Ask user if they wish to continue in spite of an order check.
- Q:'$D(PSJPDRG)  N DIR S DIR(0)="Y",DIR("A")="Do you wish to continue entering this order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
- S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="NO" D ^DIR I 'Y S PSGORQF=1,X="^",COMQUIT=1 Q
+ ;Variable PSJDDCON is the order continuation flag for Duplicate Drug Check Enhancement.
+ I $D(PSJDDCON("DD")),'PSJDDCON("DD") Q
+ I '$D(PSJDDCON("DD")) Q:'$D(PSJPDRG)  N DIR D  I 'Y S PSGORQF=1,X="^",COMQUIT=1 K PSJDDCON Q
+ . S DIR(0)="Y",DIR("A")=$S($G(PSJDDCON("DI")):"Do you wish to continue with the current order",1:"Do you wish to continue entering this order")
+ . S DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,",DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")=$S($G(PSJDDCON("DI")):"YES",1:"NO")
+ . D ^DIR
+ . Q
+ ;
+ K PSJDDCON  ;Order continuation flag for Duplicate Drug Check Enhancement.
  I 'INTERVEN!($P(PSJSYSU,";")'=3) Q
- NEW PSJY
+ N PSJY
  W:PSJIREQ !!,"This is a CRITICAL interaction, you must enter an intervention log to continue"
  S DIR(0)="Y",DIR("A")="Do you wish to log an intervention",DIR("?",1)="Enter ""N"" if you do not wish to log an intervention,",DIR("?")="or ""Y"" to log an intervention." D ^DIR S PSJY=Y D:Y ^PSJRXI
@@ -89,7 +88,9 @@
  D ENCV^PSGSETU Q:$D(XQUIT)
  F  S DIC="^PSDRUG(",DIC(0)="AEIMOQZ",DIC("A")="Select DRUG: " W ! D ^DIC K DIC Q:+Y'>0  D SF
- D ENKV^PSGSETU K N5,ND,Q,Y Q
+ D ENKV^PSGSETU K N5,ND,Q,Y
+ Q
  ;
 SF ;
+ N PSGID
  S Y=+Y,ND=$G(^PSDRUG(Y,0)),PSGID=+$G(^("I")) I PSGID W !!,"THIS DRUG IS INACTIVE AS OF ",$E($$ENDTC^PSGMI(PSGID),1,8)
  W !!,$S($P(ND,"^",9):"NON-",1:""),"FORMULARY ITEM" W:$P(ND,"^",10)]"" !,$P(ND,"^",10)
@@ -116,46 +117,2 @@
  W ?10,$P(ND,U),!,?13,"Give: ",X," ",$$ENMRN^PSGMI(+$P(ND0,U,3))," ",$P(ND2,U),!!
  Q
-ALGCLASS ; checks any Drug allergies or reactions to see if
- ;         the new drug is the same class
- ; this call can be removed by commenting out the call on IVSOL+16
- N PSJLIST,CT,CLS,CLCHK,CNT,PSJL,LIST,DCCNT,PSCLASS,LEN
- S PSCLASS=$P($G(^PSDRUG(PSJDD,0)),"^",2),LEN=4 I $E(PSCLASS,1,4)="CN10" S LEN=5 ;look at 5 chars if ANALGESICS
- I $T(GETDATA^GMRAOR)]"" G ALGC2
- S GMRA="0^0^111" D EN1^GMRADPT
- F PSJLIST=0:0 S PSJLIST=$O(GMRAL(PSJLIST)) Q:'PSJLIST  D
- .K PSJAGL D EN1^GMRAOR2(PSJLIST,"PSJAGL")
- .; is the allergy/reaction drug class first four digits the same as the
- .; the class for the drug being entered?
- .S (CT,CLS)="",DCCNT=0
- .I $D(PSJAGL("V")) D
- ..F  S DCCNT=$O(PSJAGL("V",DCCNT)) Q:'DCCNT  S:$E($P($G(PSJAGL("V",DCCNT)),"^"),1,LEN)=$E(PSCLASS,1,LEN) (PSJPDRG,CLCHK)=1,CNT=$S('$D(CNT):1,1:CNT+1),LIST(CNT)=$P($G(PSJAGL),"^")_"^"_$P($G(PSJAGL("V",DCCNT)),"^",2)
- D:$G(CLCHK)
- .W !!,$C(7),"A Drug-Allergy Reaction exists for this medication and/or class!"
- .F PSJL=0:0 S PSJL=$O(LIST(PSJL)) Q:'PSJL  D
- ..W !?6,"Drug: "_$P(LIST(PSJL),"^"),!,"Drug Class: "_$P(LIST(PSJL),"^",2),!
- Q
-ALGC2 ;
- K GMRADRCL
- D GETDATA^GMRAOR(DFN) Q:'$D(^TMP("GMRAOC",$J,"APC"))
- N GMRACL,RET
- S RET=0,GMRACL="" F  S GMRACL=$O(^TMP("GMRAOC",$J,"APC",GMRACL)) Q:'$L(GMRACL)  D
- .N GMRANM,GMRALOC
- .S GMRALOC=^TMP("GMRAOC",$J,"APC",GMRACL)
- .S GMRANM=$P(^PS(50.605,+$O(^PS(50.605,"B",GMRACL,0)),0),U,2)
- .S GMRADRCL(GMRACL)=GMRACL_U_GMRANM_" ("_GMRALOC_")"
- .S RET=RET+1
- Q:'RET  K ^TMP("GMRAOC",$J)
- S CLCHK="",CT="" F  S CT=$O(GMRADRCL(CT)) Q:CT=""  D
- .I $E(PSCLASS,1,LEN)=$E(CT,1,LEN) S CLCHK=$G(CLCHK)+1,^TMP($J,"PSJDRCLS",CLCHK)=CT_" "_$P(GMRADRCL(CT),"^",2)
-CLASSDSP ;
- I '$D(^TMP($J,"PSJDRCLS")) Q
- W $C(7),!,"A Drug-Allergy Reaction exists for this medication and/or class!",!
- W !,"Drug: "_$P($G(^PSDRUG(PSJDD,0)),"^")
- S CT="" F  S CT=$O(^TMP($J,"PSJDRCLS",CT)) Q:CT=""  W !,"Drug Class: "_^TMP($J,"PSJDRCLS",CT)
- K ^TMP($J,"PSJDRCLS")
- S DIR("?",1)="Answer 'YES' if you DO want to enter a reaction for this medication,"
- S DIR("?")="       'NO' if you DON'T want to enter a reaction for this medication,"
- S DIR(0)="SA^1:YES;0:NO",DIR("A")="Do you want to Intervene? ",DIR("B")="Y" W ! D ^DIR
- I Y D ^PSJRXI
- I '$G(Y) K DIR,DTOUT,DIRUT,DIROUT,DUOUT,Y Q
- Q
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR3.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 12/12/07
+PSGXR3 ; DRIVER FOR COMPILED XREFS FOR FILE #53.1 ; 01/17/08
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR31.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 12/12/07
+PSGXR31 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08
  ; 
  S DIKZK=2
@@ -32,5 +32,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PS(53.1,"B",$E(X,1,30),DA)
-CR1 S DIXR=502
+CR1 S DIXR=498
  K X
  S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS"))
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR310.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 12/12/07
+PSGXR310 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR311.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 12/12/07
+PSGXR311 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR312.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 12/12/07
+PSGXR312 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR32.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 12/12/07
+PSGXR32 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR33.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 12/12/07
+PSGXR33 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR34.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 12/12/07
+PSGXR34 ; COMPILED XREF FOR FILE #53.1114 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR35.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 12/12/07
+PSGXR35 ; COMPILED XREF FOR FILE #53.157 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR36.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 12/12/07
+PSGXR36 ; COMPILED XREF FOR FILE #53.158 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR37.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 12/12/07
+PSGXR37 ; COMPILED XREF FOR FILE #53.1 ; 01/17/08
  ; 
  S DIKZK=1
@@ -48,5 +48,5 @@
  S X=$P(DIKZ(.2),U,8)
  I X'="" S ^PS(53.1,"ACX",$E(X,1,30),DA)=""
-CR1 S DIXR=502
+CR1 S DIXR=498
  K X
  S DIKZ("DSS")=$G(^PS(53.1,DA,"DSS"))
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR38.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 12/12/07
+PSGXR38 ; COMPILED XREF FOR FILE #53.11 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGXR39.m	(revision 636)
@@ -1,3 +1,3 @@
-PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 12/12/07
+PSGXR39 ; COMPILED XREF FOR FILE #53.1112 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMPRU.m	(revision 636)
@@ -1,4 +1,4 @@
 PSJLMPRU ;BIR/MLM-INPATIENT LISTMAN UD PROFILE UTILITIES ;27 Aug 98 / 8:45 AM
- ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110,185**;16 DEC 97;Build 6
+ ;;5.0; INPATIENT MEDICATIONS ;**16,58,85,110**;16 DEC 97
  ;
  ; Reference to ^PSDRUG is supported by DBIA 2192.
@@ -44,11 +44,6 @@
  ;                       LM  = Begin display of text after LM spaces.
  ;                       RM  = Length of display text.
- ;
- ;BHW;PSJ*5*185;Extra spaces causes display to "skip" part of the field.                      
- ;S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD=""  D
- S PSJL="",$P(PSJL," ",LM)=""
- F X=1:1:$L(TXT," ") S WRD=$P(TXT," ",X) D
- .;BHW;PSJ*5*185;check if end of string or just extra space.
- .I WRD="" S PSJL=PSJL_" " Q
+ ;                       
+ S PSJL="",$P(PSJL," ",LM)="" F X=1:1 S WRD=$P(TXT," ",X) Q:WRD=""  D
  .I $L(PSJL_" "_WRD)'<RM D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)=""
  .I $L(PSJL_" "_WRD)'<RM S PSJL=PSJL_" "_$E(WRD,1,(RM-10)) D SETTMP(SUB,PSJL) S PSJL="",$P(PSJL," ",10)="",WRD=$E(WRD,(RM-9),$L(WRD))
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUDE.m	(revision 636)
@@ -1,6 +1,6 @@
 PSJLMUDE ;BIR/MLM-SHOW FIELDS FOR EDIT (LISTMAN STYLE) ;01 JUNE 00 / 2:40 PM
- ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175,201**;16 DEC 97;Build 2
-  ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F)
-  ;also chgs @init+23
+ ;;5.0; INPATIENT MEDICATIONS ;**7,47,50,63,64,58,80,116,110,111,164,175**;16 DEC 97;Build 18
+ ;NFI-UD Fr#:2 chgs@init+4 to display non-formulary (N/F)
+ ;also chgs @init+23
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191
@@ -12,10 +12,10 @@
  D CLEAN^VALM10
  S PSJL=$S($D(PSGEFN(1)):$E(" *",PSGEFN(1)+1)_"(1)",1:"   "),PSJL=$$SETSTR^VALM1("Orderable Item: "_PSGPDN_$$OINF^PSJDIN(PSGPD),PSJL,5,74) D  D SETTMP D:$G(PSGOEEF(108))!($G(PSGOEEF(101))) HILITE(1)
- . NEW Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S PSJDDA(+$G(^(Q,0)))=""
+ . N Q,PSJDDA,PSJVD F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S PSJDDA(+$G(^(Q,0)))=""
  . S PSJVD=$$DINFLUD^PSJDIN(PSGPD,.PSJDDA)
  . S PSJL=$$SETSTR^VALM1(PSJVD,PSJL,75,80)
  . D:PSJVD]"" CNTRL^VALM10(1,75,5,IORVON,IORVOFF,0)
  I $G(PSJORD)["P" D REQDT^PSJLIVMD(PSJORD)
- S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,80)
+ S PSJL="Instructions: "_PSGOINST D PTXT^PSJLMPRU(PSJL,"PSJUDE",6,120)
  S PSJL=$S($D(PSGEFN(2)):$E(" *",PSGEFN(2)+1)_"(2)",1:"    "),PSJL=$$SETSTR^VALM1("Dosage Ordered: "_PSGDO,PSJL,5,76) D SETTMP D:$G(PSGOEEF(109)) HILITE(2)
  I $G(PSGRDTX) S PSJDUR=$$FMTDUR^PSJLIVMD($P($G(PSGRDTX),U,2))
@@ -48,5 +48,4 @@
  S PSJL=$S($D(PSGEFN(9)):$E(" *",PSGEFN(9)+1)_"(9)",1:"   "),PSJL=$$SETSTR^VALM1("Admin Times: "_PSGAT,PSJL,8,71) D SETTMP D:$G(PSGOEEF(39))!($G(PSGOEEF(41))) HILITE(9)
  S PSJL=$S($D(PSGEFN(10)):$E(" *",PSGEFN(10)+1)_"(10)",1:"   "),PSJL=$$SETSTR^VALM1("Provider: "_PSGPRN,PSJL,11,68) D:$G(PSGOEEF(1)) HILITE(10) D SETTMP
- ;S PSJL=$$SETSTR^VALM1($S($D(PSGEFN(7)):$E(" *",PSGEFN(7)+1)_"(7)",1:"   ")_"Self Med: "_PSGSMN,PSJL,56,24) S:PSGSM&PSGHSM PSJL=$$SETSTR^VALM1("  (HS)",PSJL,71,7) D SETTMP D:$G(PSGOEEF(5)) HILITE(7)
  S PSJL=$S($D(PSGEFN(11)):$E(" *",PSGEFN(11))_"(11)",1:"   ")_" Special Instructions"_$S($P(PSGSI,"^",2)=1:"!: ",1:": ")_$P(PSGSI,"^") D PTXT^PSJLMPRU(PSJL,"PSJUDE",1,80)
  S PSJL="" D SETTMP D:$G(PSGOEEF(8)) HILITE(11)
@@ -54,6 +53,5 @@
  I $O(^PS(53.45,PSJSYSP,2,1)) F  S PSJL="" D SETTMP Q:PSJLN>15
  S PSJL=$S($D(PSGEFN(12)):$E(" *",PSGEFN(12))_" (12)",1:"   ")_" Dispense Drug",PSJL=$$SETSTR^VALM1("U/D",PSJL,54,60),PSJL=$$SETSTR^VALM1("Inactive Date",PSJL,65,16) D SETTMP,CNTRL^VALM10(13,1,80,IOUON,IOUOFF,0)
- ;S $P(PSJL,"-",80)="" D SETTMP
- NEW PSJX
+ N PSJX,PSGID
  F Q=0:0 S Q=$O(^PS(53.45,PSJSYSP,2,Q)) Q:'Q  S ND=$G(^(Q,0)) D
  .S D=$P(ND,"^"),PSGID=$P(ND,"^",3) I PSGID S PSGID=$$ENDTC^PSGMI(PSGID)
@@ -75,9 +73,10 @@
  .D SETTMP S PSJL="Order Checks:" D SETTMP
  .F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,10,Q)) Q:'Q  D
- ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) D SETTMP
+ ..S PSJL="" D SETTMP S PSJL=$G(^PS(53.1,+PSGORD,10,Q,0)) S PSJWPL=PSJL D DISPLAY
  ..S PSJL="Overriding Provider: "_$P($G(^PS(53.1,+PSGORD,10,Q,1)),U) D SETTMP
  ..S PSJL="Overriding Reason: " F X=0:0 S X=$O(^PS(53.1,+PSGORD,10,Q,2,X)) Q:'X   D
  ...S PSJL=PSJL_$G(^PS(53.1,+PSGORD,10,Q,2,X,0)) D SETTMP S PSJL="                   "
 ACTFLG ;
+ N ND4,AT,Y,X
  S ND4=$S(PSGORD["P":$G(^PS(53.1,+PSGORD,4)),1:$G(^PS(55,PSGP,5,+PSGORD,4)))
  S AT="",Y="12,13,D,18,19,H1,22,23,H0,15,16,R" F X=1:3:12 I $P(ND4,"^",$P(Y,",",X)),$P(ND4,"^",$P(Y,",",X+1)) S AT=$P(Y,",",X+2) Q
@@ -96,10 +95,15 @@
  I $G(PSGPI) S VALMSG=$S($G(VALMSG)="":"INVALID",1:VALMSG_",")_" PROVIDER"
  Q
+ ;
 DISPLAY ;
- S PSJL=PSJWPL D SETTMP
- ;F X=1:1 S WRD=$P(PSJWPL," ",X) Q:WRD=""  D
- ;.I $L(PSJL_" "_WRD)'<80 D SETTMP S PSJL=$P(PSJWPL,PSJL,2) S:$E(PSJL,1)=" " PSJL=$E(PSJL,2,999),PSJWPL="" Q
- ;.S PSJL=PSJL_$S(PSJL="":"",1:" ")_WRD
- Q
+ N X,LEN,LIM,PCS
+ S LIM=$L(PSJWPL," "),PCS=1
+ F X=1:1:LIM S LEN=$L($P(PSJWPL," ",PCS,X)) D
+ . I LEN'<72!(X=LIM) D
+ .. S PSJL=$P(PSJWPL," ",PCS,X)
+ .. I PCS>1 S PSJL="   "_PSJL
+ .. S PCS=X+1
+ .. D SETTMP
+ Q 
  ;
 SETTMP ;
@@ -108,8 +112,6 @@
  ;
 HILITE(FLD) ; 
- N COL,LIN,WID,X
- ;Q:'$G(PSGOEENO)
+ N COL,LAB,LIN,WID,X
  S X="$T("_FLD_"^PSJLMUDE)",@("X="_X),X=$P(X,";;",2),LIN=+X,COL=$P(X,",",2),LAB=$P(X,",",3),X=$P(X,",",4),WID=(LAB+$L(@X))
- ;D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IOINORM,0)
  I FLD=7 S LIN=+$G(PSJLN)-1 Q:LIN<13
  D CNTRL^VALM10(LIN,COL,WID,IORVON_IOBON,IORVOFF_IOBOFF,0)
@@ -128,3 +130,5 @@
 11 ;;11,7,22,PSGSI
 ENKILL ;
- K PSGAT,PSGEB,PSGEFN,PSGFD,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGOMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD,PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM Q
+ K PSGAT,PSGDO,PSGEB,PSGEFN,PSGFD,PSGFDN,PSGHSM,PSGNEFD,PSGNESD,PSGOEEF,PSGOEER,PSGOFD,PSGOHSM,PSGOMR,PSGMRN,PSGOPD,PSGOPDN,PSGOPR,PSGOSCH,PSGOSD
+ K PSGOSM,PSGOST,PSGPD,PSGPDN,PSGPR,PSGSD,PSGSM,PSGOINST,PSGPRN,PSGRFDN,PSGRSDN,PSGSCH,PSGSDN,PSGSI,PSGSTN,PSJWPL,RNDT
+ Q
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSJLMUT1 ;BIR/MLM-DRUG NAME DISPLAY ;05 Feb 98 / 1:39 PM
- ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175,201**;16 DEC 97;Build 2
+ ;;5.0; INPATIENT MEDICATIONS ;**4,27,29,49,58,107,110,146,175**;16 DEC 97;Build 18
  ;
  ; Reference to ^PS(55 is supported by DBIA# 2191.
@@ -25,5 +25,4 @@
  I +$O(@(F_"1,0)")),'+$O(@(F_"1,1)")),PSGUPDDO="" D DD(F,.DRUGNAME)
  S:($G(DRUGNAME)=""!($G(DRUGNAME)["NOT FOUND")) DRUGNAME=$$OIDF(OIND)
- ;S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_PSGINS_PSGUPDDO_" "_MR_" "_SCH
  S PSGGV=$S(NOTGV:"*** NOT TO BE GIVEN *** ",1:"")_$S(('$D(PSJPDDDP)&('$L(PSGUPDDO))):PSGINS,1:PSGUPDDO)_" "_MR_" "_SCH
  S PSGX=0 K PSJPDDDP
@@ -34,4 +33,5 @@
  . S NAME(PSGX+X)=$S(X>1:"      ",1:"")_MARX(X)
  Q
+ ;
 OIDF(OIND)    ; Return Orderable Item name and Dosage form.
  ;; +OIND = orderable item IEN
@@ -50,4 +50,5 @@
  S PSJPDDDP=1
  Q
+ ;
 DSPLORDU(PSGP,ON)   ; Display UD order for order check as in the Inpat Profile.
  NEW DRUGNAME,F,NODE0,NODE2,PSJID,PSJX,SCH,SD,STAT,X,Y
@@ -66,6 +67,7 @@
  . S PSJLINE=PSJLINE+1
  Q
+ ;
 DSPLORDV(DFN,ON)   ; Display IV order for order check as in the Inpat Profile.
- N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJIVFLG,PSJORIFN,TYP,X,Y
+ N DRG,DRGI,DRGT,DRGX,FIL,ND,ON55,P,PSJCT,PSJIVFLG,PSJORIFN,TYP,X,Y
  S TYP="?" I ON["V" D
  .S Y=$G(^PS(55,DFN,"IV",+ON,0)) F X=2,3,4,5,8,9,17,23 S P(X)=$P(Y,U,X)
@@ -76,8 +78,10 @@
  S PSJIVFLG=1 D PIVAD,SOL
  Q
+ ;
 SOL ;
  S PSJL=$S($G(PSJIVFLG):PSJL,1:"")_"        in"
  S DRG=0 F  S DRG=+$O(DRG("SOL",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("SOL",DRG),39,.NAME,0) S DRGX=0 F  S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,12,60) D:$G(PSJIVFLG) PIV1 D SETTMP S PSJL="      "
  Q
+ ;
 PIVAD ; Print IV Additives.
  F DRG=0:0 S DRG=$O(DRG("AD",DRG)) Q:'DRG  D NAME^PSIVUTL(DRG("AD",DRG),39,.NAME,1) F DRGX=0:0 S DRGX=$O(NAME(DRGX)) Q:'DRGX  S PSJL=$$SETSTR^VALM1(NAME(DRGX),PSJL,9,60) D:$G(PSJIVFLG) PIV1 D SETTMP
@@ -90,7 +94,9 @@
  E  S PSJL=$$SETSTR^VALM1(TYP,PSJL,50,1),PSJL=$$SETSTR^VALM1(P(2),53,7),PSJL=$$SETSTR^VALM1(P(3),PSJL,63,7),PSJL=$$SETSTR^VALM1(P(17),PSJL,73,1)
  Q
+ ;
 SETTMP ;
  S PSJOC(ON,PSJLINE)=PSJL,PSJLINE=PSJLINE+1
  Q
+ ;
 ORDCHK(DFN,TYPE,PIECE)   ;
  ;TYPE ="DD" - Duplicate drug
@@ -114,5 +120,4 @@
  . ; Adding Drug Interactions check for use in Intervention defaults in PSJRXI.
  . I TYPE="DI" S PSJRXREQ=$S($P(^TMP($J,TYPE,PSIVX,0),U,4)="CRITICAL":1,1:2)
- . ;I $P(PSJPACK,";",2)["O" D  Q
  . N X S X=$P(PSJPACK,";",2) I X["O" D  Q
  ..  D:PSJFST=1 PAUSE
@@ -123,5 +128,4 @@
  . I ON=$G(PSIVOCON),+PSJORIEN Q
  . I ON=$G(PSIVOCON),'+PSJORIEN D SETPSJOC Q
- . ;S PSJOC=PSJOC+1,PSJPDRG=1 D:PSJOC=1 WRITE(TYPE)
  . I ON["V" D
  .. I '$O(^PS(55,DFN,"IV",+ON,0)) D SETPSJOC Q
@@ -129,9 +133,22 @@
  . I ON'["V" D DSPLORDU(DFN,ON) S PSJOC=PSJOC+1
  . S PSJOC(ON,PSJLINE)="",PSJLINE=PSJLINE+1
- D:PSJOC WRITE(TYPE)
- S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  W ! S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D
- . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1 D:'(PSIVX#6) PAUSE
- W !
+ ;  DEM - If TYPE="DI", and there are "DI" orders,
+ ;        then display "DI" orders.
+ I TYPE="DI",PSJOC D WRITE(TYPE) D  ;DEM
+ . S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  S PSJLINE=PSJLINE+1,PSJFST=PSJFST+1 D  ;DEM
+ .. F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  W !,PSJOC(ON,PSIVX) S PSJLINE=PSJLINE+1  ;DEM
+ Q:(TYPE="DI")  ;DEM - Don't continue if TYPE="DI". Code that follows is for TYPEs "DD" and "DC" only.
+ Q:'PSJOC  ;DEM - No need to continue if no "DD", or "DC" orders.
+ ;  DEM - If we are here, then there are "DD", or "DC" orders in
+ ;        PSJOC array. Loop on PSJOC array and set orders into
+ ;        ^TMP($J,"DUPDRG",TYPE) global. The ^TMP($J,"DUPDRG",TYPE)
+ ;        global will be used for display of "DD" and "DC" orders
+ ;        for possible discontinuation of the "DD", or "DC" orders.
+ ;        See subroutine DUPDRG and calling routine ENDDC^PSGSICHK
+ ;        for details.
+ S ON="" F  S ON=$O(PSJOC(ON)) Q:ON=""  D  ;DEM
+ . F PSIVX=0:0 S PSIVX=$O(PSJOC(ON,PSIVX)) Q:'PSIVX  S ^TMP($J,"DUPDRG",TYPE,ON,PSIVX)=PSJOC(ON,PSIVX)  ;DEM
  Q
+ ;
 SETPSJOC ;Set PSJOC array to be displayed later
  NEW PIECE S PIECE=$S(TYPE="DC":4,1:2)
@@ -140,4 +157,5 @@
  S PSJOC(ON,PSJLINE)=X,PSJLINE=PSJLINE+1,PSJOC=PSJOC+1
  Q
+ ;
 WRITE(TYPE)        ;Display order check description
  S PSJPDRG=1
@@ -146,4 +164,5 @@
  I TYPE="DI" W !!,"This patient is receiving the following medication",$S(PSJOC>1:"s",1:"")," that ha",$S(PSJOC>1:"ve",1:"s")," an interaction",!,"with ",$P($G(^PSDRUG(PSJDD,0)),U),":",!
  Q
+ ;
 PAUSE ;
  K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJLMUT2.m	(revision 636)
@@ -1,5 +1,10 @@
 PSJLMUT2 ;BIR/JLC-DISPLAY UTILITIES ;22 Jun 05
- ;;5.0; INPATIENT MEDICATIONS ;**146,175,201**;16 DEC 97;Build 2
+ ;;5.0; INPATIENT MEDICATIONS ;**146,175**;16 DEC 97;Build 18
  ;
+ ; Reference to ^PS(55 is supported by DBIA# 2191.
+ ; Reference to ^PSDRUG is supported by DBIA# 2192.
+ ; Reference to ^PSSLOCK is supported by DBIA# 2789.
+ ; Reference to ^VA(200 is supported by DBIA# 10060.
+ ; 
 SHOR(PSJT,PSJI)       ;Display outpatient remote order checks.
  ;; PSJT = Type of order check in ^TMP
@@ -25,4 +30,5 @@
  W !,PSJULN
  Q
+ ;
 FSIG(FSIG) ;Format sig from remote site
  ;returned in the FSIG array
@@ -37,4 +43,99 @@
  I $G(FSIG(1))=""!($G(FSIG(1))=" ") S FSIG(1)=$G(FSIG(2)) K FSIG(2)
 FQUIT Q
+ ;
+DUPDRG(DFN) ;DEM - Duplicate Drug Check Ehancement
+ ;
+ ;  Note: Display of Drug Interaction, Non-VA Meds, and Outpatient
+ ;        orders is done by ORDCHK^PSJLMUT1. ORDCHK is called by
+ ;        routine ENDDC^PSGSICHK before routine ENDDC^PSGSICHK calls
+ ;        DUPDRG^PSJLMUT2. If ORDCHK finds "DD", or "DC" orders,
+ ;        then ORDCHK will set "DD", or "DC" orders into
+ ;        ^TMP($J,"DUPDRG",TYPE) global.
+ ;
+ K PSJDDCON  ;Order continuation flag used by routine PSGSICHK.
+ S:$D(^TMP($J,"DI")) PSJDDCON("DI")=1  ;Order continuation flag used by routine PSGSICHK.
+ ;  Quit if no duplicate drug orders(s), or duplicate drug class
+ ;  order(s) found.
+ Q:'$D(^TMP($J,"DUPDRG","DD"))&'$D(^TMP($J,"DUPDRG","DC"))
+ S PSJDDCON("DD")=0  ;Order continuation flag used by routine PSGSICHK.
+ ;
+ ;  Display orders in ^TMP($J,"DUPDRG",DUPLICATE_TYPE,ON,LINE_#)
+ ;  (DUPLICATE TYPEs: "DD" - "Duplicate Drug"
+ ;                    "DC" - "Duplicate Drug Class"
+ ;
+ S PSJPDRG=1  ;If we are here, then set PSJPDRG=1. ORDCHK^PSJLMUT1 addresses this variable for Outpatient orders and "DI" orders.
+ N X,Y,DIR,TYPE,ON,PSJOC,PSJOCPOP,PSJSYSL
+ W !!,"This patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!!
+ D DSPLDD  ;Display patients orders for the same drug or same drug class as drug selected.
+ ;  Ask user if they wish to continue in spite of an order check.
+ S DIR(0)="Y",DIR("A")="Do you wish to continue with the current order",DIR("?",1)="Enter ""N"" if you wish to exit without creating a new order,"
+ S DIR("?")="or ""Y"" to continue with the order entry process.",DIR("B")="YES" D ^DIR I 'Y S PSGORQF=1,COMQUIT=1 K X,Y,DIR W ! Q
+ K X,Y,DIR
+ S PSJDDCON("DD")=1,PSJSYSL=0  ;Order continuation flag used by routine PSGSICHK. 
+ W !
+ F  D  Q:('PSJOC)!(PSJOCPOP)  ;Order discontinuation loop.
+ . N TYPE,ON,PSJOCSEQ
+ . S PSJOCPOP=0
+ . ;  Ask user if they wish to discontinue any of the listed orders.
+ . S DIR(0)="Y",DIR("A")="Do you wish to DISCONTINUE any of the listed orders",DIR("?",1)="Enter ""N"" if you wish to exit without discontinuing any of the listed orders,"
+ . S DIR("?")="or ""Y"" to discontinue any of the listed orders.",DIR("B")="NO" D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q
+ . K X,Y,DIR
+ . W !
+ . ;  Choose for DISCONTINUE 1-PSJOC (PSJOC is the total number of duplicate and duplicate class orders).
+ . S DIR(0)="N^1:"_PSJOC,DIR("A")="Choose for DISCONTINUE",DIR("?")="Choose an order 1-"_PSJOC D ^DIR I 'Y K X,Y,DIR S PSJOCPOP=1 W ! Q
+ . S PSJOCSEQ=+Y
+ . K X,Y,DIR
+ . ;
+ . ;  *** Discontinue order ***
+ . S ON=$P(PSJOC(PSJOCSEQ),"^",2)
+ . I '$$LS^PSSLOCK(DFN,ON) S PSJOCPOP=1 Q
+ . S PSGSTAT=$$GTSTATUS^PSJOE(DFN,ON)
+ . D  ;Set PSGOEEWF for order being discontinued - DRF
+ .. I ON["P" S PSGOEEWF="^PS(53.1,"_+ON_"," Q
+ .. I ON["U" S PSGOEEWF="^PS(55,"_DFN_",5,"_+ON_"," Q
+ .. S PSGOEEWF="^PS(55,"_DFN_",""IV"","_+ON_","
+ . D  ;The following variables must be newed or they are stomped on by the discontinue code
+ .. N %DT,CF,D,D0,DA,DI,DIC,DIE,DISYS,DQ,DR,DRG,DRGT,DRGTMP,DRGX
+ .. N DTIME,FIL,I,JJ,LOC,OCXDT,OCXI,OCXSEG,ORIFN,ORO,POP,PSGALR
+ .. N PSGDT,PSGOEAV,PSJNOO,PSGOEDMR,PSGOEPR,PSGPDRG,PSGTOO,PSGTOL
+ .. N PSGUOW,PSIVOI,PSIVX,PSJCOM,PSJDD,PSJHLMTN,PSJMSG,PSJQO,PSOC
+ .. N Q,QQ,T,VA,VADM,VAERR,VAIN,XPARSYS,XQXFLG,Y,PSJRQPND
+ .. D
+ ... S PSJRQPND=1
+ ... I ON["V" D  Q  ;IV order
+ .... N PSJORD
+ .... S PSJORD=ON
+ .... D DC^PSJLIACT
+ ... D DC^PSJOE(DFN,ON)  ;UD order
+ .. I $$GTSTATUS^PSJOE(DFN,ON)="D" D  ;  Clean up PSJOC and ^TMP($J,"DUPDRG") arrays, and reset PSJOC counter IF and after selected order has been discontinued.
+ ... S TYPE=$P(PSJOC(PSJOCSEQ),"^",1),ON=$P(PSJOC(PSJOCSEQ),"^",2),PSJOC=PSJOC-1
+ ... K PSJOC(PSJOCSEQ),^TMP($J,"DUPDRG",TYPE,ON),PSJOCSEQ
+ . D UNL^PSSLOCK(DFN,ON)
+ . Q:'PSJOC
+ . W !!,"Now, this patient is already receiving the following INPATIENT order(s) for the same drug or in the same drug class as "_$S($G(PSJDD)]"":$P($G(^PSDRUG(PSJDD,0)),U),1:"the drug selected"),":",!!
+ . D DSPLDD
+ . Q
+ W !
+ K PSJOCPOP,PSGSTAT
+ Q
+ ;
+DSPLDD ;
+ ;  Display patients orders for the same drug or same drug class as drug selected.
+ N X,REQPROV,PSJLINE,PSJFLN
+ K PSJOC
+ ;  Requesting Provider
+ S PSJOC=0
+ F TYPE="DD","DC" S ON="" F  S ON=$O(^TMP($J,"DUPDRG",TYPE,ON)) Q:ON=""  S PSJFLN=1 D
+ . I ON["U" S REQPROV=$P(^PS(55,DFN,5,+ON,0),"^",2)
+ . I ON["V" S REQPROV=$P(^PS(55,DFN,"IV",+ON,0),"^",6)
+ . I ON["P" S REQPROV=$P(^PS(53.1,+ON,0),"^",2)
+ . S REQPROV=$S(REQPROV>0:$P($G(^VA(200,REQPROV,0)),"^",1),1:"") S:REQPROV="" REQPROV="Requesting Provider Unknown"
+ . F PSJLINE=0:0 S PSJLINE=$O(^TMP($J,"DUPDRG",TYPE,ON,PSJLINE)) Q:'PSJLINE  D
+ .. I PSJFLN=1 S PSJOC=PSJOC+1,PSJOC(PSJOC)=TYPE_"^"_ON W PSJOC_".",^TMP($J,"DUPDRG",TYPE,ON,PSJLINE),! S PSJFLN=PSJFLN+1 Q
+ .. S X=^TMP($J,"DUPDRG",TYPE,ON,PSJLINE) S:PSJFLN=2 X=$$SETSTR^VALM1(REQPROV,X,(48+$L(PSJOC_".")),25) W ?($L(PSJOC_".")),X,! S PSJFLN=PSJFLN+1 Q
+ .. Q
+ . Q
+ Q
+ ;
 PAUSE ;
  K DIR W ! S DIR(0)="EA",DIR("A")="Press Return to continue..." D ^DIR W !
Index: FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m
===================================================================
--- FOIAVistA/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m	(revision 631)
+++ FOIAVistA/tag/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJMPEND.m	(revision 636)
@@ -1,4 +1,4 @@
-PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ; 6/18/07 12:11pm
- ;;5.0; INPATIENT MEDICATIONS ;**191**;16 DEC 97;Build 9
+PSJMPEND ;BIR/CML3-MD MARS - GATHER ACK ORDERS INFO (MDWS) ;20 DEC 96 / 3:15 PM
+ ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
  ;
 PEND ;*** Only select orders that were acknowledged by nurses and are
@@ -8,5 +8,4 @@
  F ON=0:0 S ON=$O(^PS(53.1,"AV",PSGP,ON)) Q:'ON  D
  . S ND=$G(^PS(53.1,ON,0)),TYPE=$P(ND,U,4)
- . S ND2=$G(^PS(53.1,ON,2)),PSGLSD=$P(ND2,U,2),PSGLFD=$P(ND2,U,4)
  . I $P(ND,U,7)="P"!($P($G(^PS(53.1,ON,2)),U)["PRN") S QST="PZ"_$S($P(ND,U,4)="F":"V",1:"A")
  . E  S QST="CZ"_$S($P(ND,U,4)="F":"V",1:"A")
@@ -25,5 +24,5 @@
  D DRGDISP^PSJLMUT1(PSGP,+ON_"P",20,0,.MARX,1) S DRG=MARX(1)_U_ON
  ;*** Set up ^TMP for sort by patients
- S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCHE=$P($G(^PS(53.1,ON,2)),U)
+ S PSJDOS=$P(^PS(53.1,ON,.2),U,2),PSJMR=$E($S($P(ND,U,3)]"":$P(ND,U,3),1:$P(ND,U)),1,5),PSJSCH=$P($G(^PS(53.1,ON,2)),U)
  S PSJHOLD=$S($P(ND,U,9)["H":1,1:0),PSGLOD=$P(ND,U,14),PSJATME=9999,PSJADT=$S(QST["C":"8999999",1:"9999999")
  D SI
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATER.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATER.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATER.m	(revision 636)
@@ -1,5 +1,5 @@
 IBATER ;LL/ELZ - TRANSFER PRICING PROSTHETICS DRIVER ; 7-APR-2000
- ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ; This routine is called by the nightly back ground job.  It will go
@@ -22,5 +22,5 @@
 CHECK ; check if transfer pricing and not already added
  ;
- N IBDATA,IBDATA1,IBDFN
+ N IBDATA,IBDFN
  ;
  ; already in file
@@ -28,12 +28,12 @@
  ;
  ; valid tp patient
- S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""  S IBDATA1=$G(^RMPR(660,+IBDA,1))
+ S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
  S IBDFN=$P(IBDATA,"^",2) Q:'IBDFN  Q:'$$TPP^IBATUTL(IBDFN)
  ;
  ; checks from RMPRBIL copied 4/7/2000 with mod for patient type removed
- I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
+ I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
  ;
  ; now if inpt, must be in 351.67
- I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA1,"^",4))) Q
+ I $P(^RMPR(660,IBDA,"AM"),"^",3)'=1,$P(^("AM"),"^",3)'=4,'$D(^IBAT(351.67,"B",$P(IBDATA,"^",6))) Q
  ;
  Q:'$P(IBDATA,"^",16)  ; no total cost, at least yet
@@ -41,5 +41,5 @@
 FILE ; ok transaction needs to be filled in tp files
  ;
- S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
+ S IBDATA=$$RMPR^IBATFILE(IBDFN,IBDT,$$PPF^IBATUTL(IBDFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16))
  ;
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m	(revision 636)
@@ -1,5 +1,5 @@
 IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING  ; 22-JAN-1999
- ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
 PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn
  Q:'$G(DA) 0
@@ -104,11 +104,11 @@
  ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
  ; IBSOURCE=source (prost ien;RMPR(660,
- ; IBPROS=ien from file 661 - removed in 389 no longer valid
+ ; IBPROS=ien from file 661
  ; IBCOST=item cost
- I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
+ I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) Q 0
  N IBIEN
  S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
  S DIE="^IBAT(351.61,",DA=IBIEN
- S DR=".1////"_+IBEDT_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
+ S DR=".1////"_+IBEDT_";4.04////"_+IBPROS_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
  L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
  D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM1B.m	(revision 636)
@@ -1,5 +1,5 @@
 IBATLM1B ;LL/ELZ - TRANSFER PRICING TRANSACTION LIST MENU ; 15-SEP-1998
- ;;2.0;INTEGRATED BILLING;**115,261,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115,261**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 CF ; -- change facility from patient level
@@ -129,5 +129,5 @@
  Q
 R ; -- select an prosthetic
- N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBDATA1,IBP,IBC,IBCOUNT,%,DIRUT
+ N IBBDT,IBEDT,IBCOUNT,IBOUT,IBDA,IBDATA,IBP,IBC,IBCOUNT,%,DIRUT
  ;
  S (IBCOUNT,IBOUT)=0
@@ -138,5 +138,5 @@
  . ;
  . ; valid data
- . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""  S IBDATA1=$G(^RMPR(660,+IBDA,1))
+ . S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
  . ;
  . ; valid date range
@@ -144,5 +144,5 @@
  . ;
  . ; checks from RMPRBIL copied 4/7/2000 with mod for AM node patients
- . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA1,"^",4)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
+ . I $S('$D(^RMPR(660,IBDA,"AM")):1,$P(IBDATA,"^",9)="":1,$P(IBDATA,"^",12)="":1,$P(IBDATA,"^",6)="":1,$P(IBDATA,"^",14)="V":1,$P(IBDATA,"^",15)="*":1,1:0) Q
  . ;
  . ; set array
@@ -155,5 +155,5 @@
  . S IBDATA=IBP(IBC,$O(IBP(IBC,0)))
  . W !,IBC,?4,$$FMTE^XLFDT($P(IBDATA,"^",12),"5D")
- . W ?20,$E($P($$PIN^IBATUTL($O(IBP(IBC,0))),U,2),1,28),?50,"("
+ . W ?20,$$EX^IBATUTL(660,4,$P(IBDATA,"^",6)),?40,"("
  . W $$EX^IBATUTL(660,62,$P(^RMPR(660,$O(IBP(IBC,0)),"AM"),"^",3)),")"
  . W ?65,$J($FN($P(IBDATA,"^",16),",",2),12)
@@ -166,5 +166,5 @@
  I $D(DIRUT) D H Q
  W !!,"Adding Transaction number ",$$SITE^IBATUTL
- W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),,$P(IBDATA,"^",16))
+ W $$RMPR^IBATFILE(DFN,$P(IBDATA,"^",12),$$PPF^IBATUTL(DFN),(IBDA_";RMPR(660,"),$P(IBDATA,"^",6),$P(IBDATA,"^",16))
  W "!" H 1
  D H
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATLM2A.m	(revision 636)
@@ -1,5 +1,5 @@
 IBATLM2A ;LL/ELZ - TRANSFER PRICING PT TRANSACTION DETAIL ; 15-SEP-1998
- ;;2.0;INTEGRATED BILLING;**115,210,266,309,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115,210,266,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  N IBX,IBY K ^TMP("IBATEE",$J)
@@ -150,6 +150,6 @@
  D SETVALM(.VALMCNT,"")
  D SET("Prosthetic Item:",.IBY,5,16)
- D SET($P($$PIN^IBATUTL(+$P(IBDATA(0),"^",12)),U,2),.IBY,23,30) ; dbia 374
- D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,58,15)
+ D SET($$GET1^DIQ(661,$P(IBDATA(4),"^",4),.01),.IBY,12,40) ; dbia 374
+ D SET($FN($P(IBDATA(4),"^",5),",",2),.IBY,55,15)
  D SETVALM(.VALMCNT,.IBY)
  D SETVALM(.VALMCNT,"")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m	(revision 636)
@@ -1,5 +1,5 @@
 IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
- ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 PAGE() ; performs page reads and returns 1 if quiting is needed
@@ -40,5 +40,5 @@
  . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
  I $P(IBA(0),"^",12)["RMPR(660," D  Q
- . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)
+ . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.04,$P(IBA(4),"^",4)),1,18)
  S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
  S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATUTL.m	(revision 636)
@@ -1,4 +1,4 @@
 IBATUTL ;LL/ELZ - TRANSFER PRICING UTILITES ; 3-SEP-1998
- ;;2.0;INTEGRATED BILLING;**115,266,347,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**115,266,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -161,12 +161,4 @@
  Q Z
  ;
-PIN(P660,P6611) ; return Prosthetics Item Description (#661.1,.02)
- ; input:  P660 - pointer to Patient Item (#660) or P6611 - pointer to HCPCS (#661.1)
- ; return: pointer to HCPCS (#661.1) ^ Short Description (#661.1,.01) ^ HCPCS (#661.1,.01)
- N IBX,IBY S IBY=""
- I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
- I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
- Q IBY
- ;
 EX(FILE,FIELD,VALUE) ; -- return external value
  N Y,C S Y=$G(VALUE)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCBB ;ALB/AAS - EDIT CHECK ROUTINE TO BE INVOKED BEFORE ALL BILL APPROVAL ACTIONS ;2-NOV-89
- ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**80,51,137,288,327,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -23,9 +23,13 @@
  ;
 EN ;Entry to check for errors
- N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBFOR,IBC
+ N IBQ,IBXERR,IBXDATA,IBXSAVE,IBZPRC92,IBQUIT,IBISEQ,IDDATA,IBERRNO
  I $D(IBFL) N IBFL
  K ^TMP($J)
  W !
  S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q
+ ;
+ ;I $$ISPROS^IBCEF1(IBIFN) D
+ ;. D WARN^IBCBB11("Bill has prosthetics item(s) and will only print locally")
+ ;. I $$NEEDMRA^IBEFUNC(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,"098")
  ;
  ;patient in patient file
@@ -41,4 +45,5 @@
  I IBAT]"",'$D(^DGCR(399.3,IBAT,0)) S IBER=IBER_"IB059;"
  I IBAT]"",$D(^DGCR(399.3,IBAT,0)),'$P(^(0),"^",6) S IBER=IBER_"IB059;",IBAT=""
+ ;I IBAT]"",$D(^DGCR(399.3,IBAT,0)) S IBARTP=$P(^PRCA(430.2,$P(^DGCR(399.3,IBAT,0),"^",6),0),"^",6)
  I IBAT]"",$P($G(^DGCR(399.3,IBAT,0)),"^",6) S IBARTP=$P($$CATN^PRCAFN($P(^DGCR(399.3,IBAT,0),"^",6)),"^",3)
  ;Check that AR category expects same debtor as defined in who's responsible.
@@ -77,118 +82,10 @@
  . S IDDATA=$$INSDEM^IBCEF(IBIFN,IBISEQ)
  . K ^UTILITY("VADM",$J),^UTILITY("VAPA",$J)
- . ;
- . I '$P(IDDATA,U,1) D ERR(221)   ; birth date missing
- . ;
- . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D ERR(261)  ; sex missing
- . ;
- . ; IB*2*371 - esg - check for other missing insurance pieces
- . ; check insured's name, primary ID#, pt. relationship to insured,
- . ; and subscriber address data  
- . N INNAME,SUBID,PTREL,SFA,CAS,LN,FN
- . ;
- . ;          IB273 - Primary Insurance name of insured missing
- . ;          IB274 - Secondary Insurance name of insured missing
- . ;          IB275 - Tertiary Insurance name of insured missing
- . S INNAME=$$POLICY^IBCEF(IBIFN,17,IBISEQ)
- . S LN=$P(INNAME,",",1),FN=$P(INNAME,",",2)   ; last name,first name
- . S LN=$$NOPUNCT^IBCEF(LN,1)
- . S FN=$$NOPUNCT^IBCEF(FN,1)
- . I LN=""!(FN="") D ERR(273)   ; name of insured missing or invalid
- . S LN=$$NAME^IBCEFG1(INNAME)  ; additional name checks
- . S FN=$P(LN,U,2)
- . S LN=$P(LN,U,1)
- . I LN=""!(FN="") D ERR(273)   ; name of insured missing or invalid
- . ;
- . ;          IB276 - Primary Insurance subscriber ID missing
- . ;          IB277 - Secondary Insurance subscriber ID missing
- . ;          IB278 - Tertiary Insurance subscriber ID missing
- . S SUBID=$$NOPUNCT^IBCEF($$POLICY^IBCEF(IBIFN,2,IBISEQ),1)
- . I SUBID="" D ERR(276)     ; subscriber ID# missing
- . ;
- . ;          IB279 - Primary Insurance missing pt relationship
- . ;          IB280 - Secondary Insurance missing pt relationship
- . ;          IB281 - Tertiary Insurance missing pt relationship
- . S PTREL=$$POLICY^IBCEF(IBIFN,16,IBISEQ)
- . I PTREL="" D ERR(279)      ; missing patient relationship to insured
- . ;
- . ; subscriber address section
- . S SFA=$$INSADDR^IBCEF(IBIFN,IBISEQ)     ; full address all pieces
- . S CAS=$$NOPUNCT^IBCEF($P(SFA,U,2,5),1)  ; string city,st,zip,addr1
- . ;
- . ;          IB282 - Primary Insurance address line 1 missing
- . ;          IB283 - Secondary Insurance address line 1 missing
- . ;          IB284 - Tertiary Insurance address line 1 missing
- . I $$NOPUNCT^IBCEF($P(SFA,U,5),1)="" D   ; address line 1 is blank
- .. ; pat=subscriber and current insurance - address is required
- .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(282) Q
- .. ; if any part of the address is there, then all fields are required
- .. I CAS'="" D ERR(282) Q
- .. Q
- . ;
- . ;          IB285 - Primary Insurance city missing
- . ;          IB286 - Secondary Insurance city missing
- . ;          IB287 - Tertiary Insurance city missing
- . I $$NOPUNCT^IBCEF($P(SFA,U,2),1)="" D   ; city is blank
- .. ; pat=subscriber and current insurance - address is required
- .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(285) Q
- .. ; if any part of the address is there, then all fields are required
- .. I CAS'="" D ERR(285) Q
- .. Q
- . ;
- . ;          IB288 - Primary Insurance state missing
- . ;          IB289 - Secondary Insurance state missing
- . ;          IB290 - Tertiary Insurance state missing
- . I $$NOPUNCT^IBCEF($P(SFA,U,3),1)="" D   ; state is blank
- .. ; pat=subscriber and current insurance - address is required
- .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(288) Q
- .. ; if any part of the address is there, then all fields are required
- .. I CAS'="" D ERR(288) Q
- .. Q
- . ;
- . ;          IB291 - Primary Insurance zipcode missing
- . ;          IB292 - Secondary Insurance zipcode missing
- . ;          IB293 - Tertiary Insurance zipcode missing
- . I $$NOPUNCT^IBCEF($P(SFA,U,4),1)="" D   ; zipcode is blank
- .. ; pat=subscriber and current insurance - address is required
- .. I +PTREL=1,IBISEQ=$$COBN^IBCEF(IBIFN) D ERR(291) Q
- .. ; if any part of the address is there, then all fields are required
- .. I CAS'="" D ERR(291) Q
- .. Q
- . ;
- . Q
- ;
- ; esg - IB*2*371 - check patient address fields
- K ^UTILITY("VAPA",$J)
- ;
- S IBFOR=0                              ; foreign address flag
- S IBC=+$$PTADDR^IBCEF(IBIFN,25)        ; country code ien
- I IBC D
- . N CODE
- . S CODE=$$GET1^DIQ(779.004,IBC,.01)   ; .01 code field file 779.004
- . I CODE'="",CODE'="USA" S IBFOR=1     ; foreign country exists
- . Q
- ;
- I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,1),1)="" S IBER=IBER_"IB269;"
- I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,4),1)="" S IBER=IBER_"IB270;"
- I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,5),1)="",'IBFOR S IBER=IBER_"IB271;"
- I $$NOPUNCT^IBCEF($$PTADDR^IBCEF(IBIFN,11),1)="",'IBFOR S IBER=IBER_"IB272;"
- K ^UTILITY("VAPA",$J)
- ;
- D PAYERADD^IBCBB0(IBIFN)     ; check the payer addresses
- ;
- ; esg - 9/20/07 - IB patch 371 - prevent EDI transmission for 3 payer
- ;       claims for all but the first payer.  To be removed when Emdeon
- ;       and FSC are able to deal with these.
- ;
- I +$G(^DGCR(399,IBIFN,"I2")),+$G(^DGCR(399,IBIFN,"I3")),$$TXMT^IBCEF4(IBIFN) D
- . ; for MRA request claims, make sure the MRA secondary claim is forced to print
- . I $$REQMRA^IBEFUNC(IBIFN) D  Q
- .. I '$P($G(^DGCR(399,IBIFN,"TX")),U,9) S IBER=IBER_"IB146;"
- .. Q
- . ;
- . I $$COBN^IBCEF(IBIFN)=1 Q   ; primary payer sequence claims are OK
- . ;
- . ; But claims with a payer sequence of 2 or 3 need to print locally
- . S IBER=IBER_"IB147;"
+ . I '$P(IDDATA,U,1) D  ; birth date missing
+ .. S IBERRNO=220+IBISEQ
+ .. S IBER=IBER_"IB"_IBERRNO_";"
+ . I "^M^F^"'[(U_$P(IDDATA,U,2)_U) D  ; sex missing
+ .. S IBERRNO=260+IBISEQ
+ .. S IBER=IBER_"IB"_IBERRNO_";"
  . Q
  ;
@@ -207,10 +104,2 @@
  Q ($P(IBND0,U,24)_$P($G(^DGCR(399.1,+$P(IBND0,U,25),0)),U,2)_$P(IBND0,U,26))
  ;
-ERR(Z) ; update IBER variable from the above insurance checks
- ; Z is the IB error code# for the primary insurance error
- N IBERRNO
- S IBERRNO="IB"_(Z+IBISEQ-1)
- I IBER[IBERRNO Q
- S IBER=IBER_IBERRNO_";"
- Q
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCBB1 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;2-NOV-89
- ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363,371,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**27,52,80,93,106,51,151,148,153,137,232,280,155,320,343,349,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -23,4 +23,10 @@
  S IBTFY=$$FY^IBOUTL(IBTDT)
  ;
+ ;Statement crosses fiscal years
+ ;I IBTFY'=IBFFY S IBER=IBER_"IB047;"
+ ;
+ ;Statement crosses calendar years
+ ;I $E(IBTDT,1,3)'=$E(IBFDT,1,3) S IBER=IBER_"IB046;"
+ ;
  ;Total Charges
  I +IBTC'>0!(+IBTC'=IBTC) S IBER=IBER_"IB064;"
@@ -37,4 +43,8 @@
  I IBAU]"",'$D(^VA(200,IBAU,0)) S IBER=IBER_"IB041;"
  ;
+ ;Bill exists and not already new bill
+ ;I $S('$D(^PRCA(430,IBIFN,0)):1,$P($P(^PRCA(430,IBIFN,0),"^"),"-",2)'=IBBNO:1,1:0) S IBER=IBER_"IB056;"
+ ;I $P($$BN^PRCAFN(IBIFN),"-",2)'=IBBNO S IBER=IBER_"IB056;"
+ ;I IBER="",$P(^PRCA(430,IBIFN,0),"^",8)=$O(^PRCA(430.3,"AC",104,"")) S IBER=IBER_"IB040;"
  I IBER="",+$$STA^PRCAFN(IBIFN)=104 S IBER=IBER_"IB040;"
  ; If ins bill, must have valid COB sequence
@@ -46,7 +56,4 @@
  ; Check NPIs
  D NPICHK^IBCBB11
- ;
- ; Check multiple rx NPIs
- D RXNPI^IBCBB11(IBIFN)
  ;
  ; Check taxonomies
@@ -68,6 +75,7 @@
  ... S Q0=0 F  S Q0=$O(IBID(1,FUNCTION,Q0)) Q:'Q0  I $P(IBID(1,FUNCTION,Q0),U,9)=+Z S IBOK=1 Q
  ... I 'IBOK S IBER=IBER_$S(IBINS=1:"IB236;",IBINS=2:"IB237;",IBINS=3:"IB238;",1:"")
- ;
- D PRIIDCHK^IBCBB11
+ . I $$TXMT^IBCEF4(IBIFN) D
+ .. D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
+ .. I $P(IBZ,U,3)=""&($P(IBZ,U,4)="") S IBER=IBER_"IB321;" ; SSN/IEN required for rend/att
  ;
  N IBM,IBM1
@@ -133,7 +141,5 @@
  F Z=0:1:2 S Z0=$O(Z(Z)) Q:'Z0  I Z0'=(Z+1) S IBER=IBER_"IB322;" Q
  K Z
- ; HD64676  IB*2*371 - OK for payer sequence to be blank when the Rate
- ;    Type is either Interagency or Sharing Agreement
- I $P($G(^DGCR(399,IBIFN,0)),U,21)="",$P($G(^DGCR(399,IBIFN,0)),U,7)'=4,$P($G(^DGCR(399,IBIFN,0)),U,7)'=9 S IBER=IBER_"IB323;"
+ I $P($G(^DGCR(399,IBIFN,0)),U,21)="" S IBER=IBER_"IB323;"
  K IBXDATA D F^IBCEF("N-PROCEDURE CODING METHD",,,IBIFN)
  ; Coding method should agree with types of procedure codes
@@ -153,5 +159,4 @@
  ;
  D VALNDC^IBCBB11(IBIFN,DFN)  ;validate NDC#
- ;
  ;Build AR array if no errors and MRA not needed or already rec'd
  I IBER="",$S($$NEEDMRA^IBEFUNC(IBIFN)!($$REQMRA^IBEFUNC(IBIFN)):0,1:1) D ARRAY
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB11.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCBB11 ;ALB/AAS - CONTINUATION OF EDIT CHECK ROUTINE ;12 Jun 2006  3:45 PM
- ;;2.0;INTEGRATED BILLING;**51,343,363,371,395,392**;21-MAR-94;Build 2
+ ;;2.0;INTEGRATED BILLING;**51,343,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -52,6 +52,5 @@
  S IBTAXS=$$PROVTAX^IBCEF73A(IBIFN,.IBNOTAX)
  I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
- . ; Only Referring, Rendering and Attending are currently sent to the payer
- . I IBTAXREQ,"134"[$P(IBNOTAX,U,Z) S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
+ . I IBTAXREQ S IBER=IBER_"IB"_(250+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
  . D WARN("Taxonomy for the "_$P("referring^operating^rendering^attending^supervising^^^^other",U,$P(IBNOTAX,U,Z))_" provider has no value")  ; Else, set warning
  ; Check organizations
@@ -59,11 +58,10 @@
  S IBTAXS=$$ORGTAX^IBCEF73A(IBIFN,.IBNOTAX)
  I $L(IBNOTAX) F Z=1:1:$L(IBNOTAX,U) D
- . ; These are not currently sent to the payer so no errors yet
- . ; I IBTAXREQ S IBER=IBER_"IB"_(164+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
+ . I IBTAXREQ S IBER=IBER_"IB"_(164+$P(IBNOTAX,U,Z))_";" Q  ; If required, set error
  . ; PRXM/KJH - Changed descriptions.
  . D WARN("Taxonomy for the "_$P("Division^Non-VA Service Facility^Billing Provider",U,$P(IBNOTAX,U,Z))_" has no value")  ; Else, set warning
  Q
  ;
-VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52)
+VALNDC(IBIFN,IBDFN) ; IB*2*363 - validate NDC# between PRESCRIPTION file (#52) 
  ; and IB BILL/CLAIMS PRESCRIPTION REFILL file (#362.4)
  ; input - IBIFN = internal entry number of the billing record in the BILL/CLAIMS file (#399)
@@ -76,20 +74,2 @@
  S IBX=0 F  S IBX=$O(IBRXCOL(IBX)) Q:'IBX  D WARN("NDC# on Bill does not equal the NDC# on Rx "_IBRXCOL(IBX))
  Q
- ;
-PRIIDCHK ; Check for required Pimarary ID (SSN/EIN)
- ; If the provider is on the claim, he must have one
- ; 
- N IBI,IBZ
- I $$TXMT^IBCEF4(IBIFN) D
- . D F^IBCEF("N-ALL ATT/REND PROV SSN/EI","IBZ",,IBIFN)
- . S IBI="" F  S IBI=$O(^DGCR(399,IBIFN,"PRV","B",IBI)) Q:IBI=""  D
- .. I $P(IBZ,U,IBI)="" S IBER=IBER_$S(IBI=1:"IB151;",IBI=2:"IB152;",IBI=3!(IBI=4):"IB321;",IBI=5:"IB153;",IBI=9:"IB154;",1:"")
- Q
- ;
-RXNPI(IBIFN) ; check for multiple pharmacy npi's on the same bill
- N IBORG,IBRXNPI,IBX,IBY
- S IBORG=$$RXSITE^IBCEF73A(IBIFN,.IBORG)
- S IBX=0 F  S IBX=$O(IBORG(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(IBORG(IBX,IBY)) Q:'IBY  S IBRXNPI(+IBORG(IBX,IBY))=""
- S (IBX,IBY)=0 F  S IBX=$O(IBRXNPI(IBX)) Q:'IBX  S IBY=IBY+1
- I IBY>1 D WARN("Bill has prescriptions resulting from "_IBY_" different NPI locations")
- Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB2.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCBB2 ;ALB/ARH - CONTINUATION OF EDIT CHECKS ROUTINE (CMS-1500) ;04/14/92
- ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,210,245,232,296,320,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -6,8 +6,12 @@
  ;
 EN ;
- N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT,IBNVFLG,IBU3
+ N IBI,IBJ,IBN,IBY,IBDX,IBDXO,IBDXL,IBCPT,IBCPTL,IBOLAB,Z,IBXSAVE,IBLOC,IBTX,IBPS,IBSP,IBLCT
  I '$D(IBER) S IBER=""
  S IBTX=$$TXMT^IBCEF4(IBIFN)
  ;
+ ; Warn if no group provider id (MCRWNR is a default)
+ ; I '$$WNRBILL^IBEFUNC(IBIFN) D
+ ; . S Z=$P($G(^DGCR(399,IBIFN,"M1")),U,$$COBN^IBCEF(IBIFN)+1)
+ ; . I Z="" D WARN^IBCBB11("No group prov # for the current ins co - site tax id will be used")
  ; Max 4 modifiers per CPT code allowed before warning
  K IBXDATA
@@ -22,7 +26,9 @@
  ; CPT procs must be associated with a dx, must have a defined provider
  S (IBLOC,IBN,IBI,IBY)=0 F  S IBI=$O(^DGCR(399,IBIFN,"CP",IBI)) Q:IBI'?1N.N  S IBCPT=^(IBI,0) D  I +IBY S IBN=1
+ . ;I IBER'["IB089",$P(IBCPT,U,10)=7,$S('$P(IBCPT,U,16):1,1:$P(IBCPT,U,16)#15) S IBER=IBER_"IB089;" ;anesthesia needs minutes in multiple of 15
  . I 'IBLOC,$P(IBCPT,U,15)'="",IBTX S Z="At least 1 charge has local box 24K data that will not be transmitted - " S IBLOC=1 D WARN^IBCBB11(Z) S Z="  This data will only print locally" D WARN^IBCBB11(Z)
  . I $P(IBCPT,U)'["ICPT(" S:IBER'["IB092" IBER=IBER_"IB092;" Q
  . S IBY=1 F IBJ=11:1:14 I +$P(IBCPT,"^",IBJ) S IBCPTL(+$P(IBCPT,"^",IBJ))="",IBY=0
+ . ;I '$P(IBCPT,U,18) S:IBER'["IB094;" IBER=IBER_"IB094;" Q
  I +IBN S IBER=IBER_"IB072;"
  ;
@@ -46,9 +52,4 @@
  S Z=$$EVENT^IBCF22(IBIFN,.IBXSAVE,.IBI)
  I IBI S IBER=IBER_"IB099;"
- ;
- ; esg - 6/6/07 - warning if missing non-VA care type for outside facility
- S IBNVFLG=0
- I $P(IBNDU2,U,10),'$P(IBNDU2,U,11) D WARN^IBCBB11("Non-VA facility indicated, but the Non-VA Care Type field is not defined") S IBNVFLG=1
- ;
  ; unit/charge limits
  K IBXDATA
@@ -61,5 +62,4 @@
  .. I $P(IBXDATA(IBI),U,14),"24"'[$P(IBNDU2,U,11) D WARN^IBCBB11("Outside lab charges exist on a non-lab NON-VA bill")
  . I '$P(IBNDU2,U,11),$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Purchased service amounts are invalid unless this is a NON-VA bill")
- . I IBNVFLG,'$P(IBXDATA(IBI),U,11) D WARN^IBCBB11("Non-VA facility indicated, but no purchased service charge on line# "_IBI)
  . I $D(IBXDATA(IBI,"A")) S IBER=IBER_"IB310;" Q
  . I $D(IBXDATA(IBI,"ARX")),IBER'["311;" S IBER=IBER_"IB311;" Q
@@ -78,13 +78,9 @@
  . I IBER'["IB090",$P(IBXDATA(IBI),U,9)'<10000 S IBER=IBER_"IB090;"
  . I '($P(IBXDATA(IBI),U,9)*$P(IBXDATA(IBI),U,8)),$$COBN^IBCEF(IBIFN)'>1 S Z="Procedure "_$P(IBXDATA(IBI),U,5)_" has a 0-charge and will not be transmitted" D WARN^IBCBB11(Z)
+ . I $G(IBXDATA(IBI,"AUX"))'="",'$G(IBSP(1)),+IBSP'=35,$TR($P(IBXDATA(IBI,"AUX"),U,4,6)_$P(IBXDATA(IBI,"AUX"),U,2),U)'="" S IBSP(1)=1
  I IBTX,IBLCT>50 D
  . I '$$REQMRA^IBEFUNC(IBIFN) S IBER=IBER_"IB308;" Q
  . I '$P(IBNDTX,U,9) S IBER=IBER_"IB325;"
- S IBU3=$P($G(^DGCR(399,IBIFN,"U3")),U,4,7) I $TR(IBU3,U)'="" D
- .I +IBSP'=35 D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
- .I $P(IBU3,U,2)="" S IBER=IBER_"IB137;"
- .I $P(IBU3,U,4)="" S IBER=IBER_"IB138;" Q
- .I $P(IBU3,U,3)="","AM"[$P(IBU3,U,4) S IBER=IBER_"IB139;"
- .Q
+ I $G(IBSP(1)) D WARN^IBCBB11("Chiropractic service details only valid if provider specialty is '35'")
  I IBPS'="" D WARN^IBCBB11("NON-VA facility indicated, but no purchased service charge on line item"_$S(IBPS[",":"s",1:"")_" #"_IBPS)
  I $P(IBNDU2,U,11),$P(IBNDU2,U,11)=4,IBOLAB>1 D WARN^IBCBB11("For proper payment, you must bill each outside lab on a separate claim form")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB3.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCBB3 ;ALB/TMP - CONTINUATION OF EDIT CHECKS ROUTINE (MEDICARE) ;06/23/98
- ;;2.0;INTEGRATED BILLING;**51,137,155,349,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -21,5 +21,5 @@
  I $G(IBXDATA)="",IBFT=3 D  Q:IBQUIT
  . N Z
- . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER(.IBER,231) Q
+ . I "^11^18^"[(U_IBTOB12_U) S IBQUIT=$$IBER^IBCBB3(.IBER,231) Q
  . I $$INPAT^IBCEF(IBIFN,1) S Z="Admitting Diagnosis may be required by payer, please verify" D WARN^IBCBB11(Z)
  ;
@@ -27,5 +27,5 @@
  S IBOK=1,Z=0,IBZP=U F  S Z=$O(Z(Z)) Q:'Z  S:$S($P($G(Z(Z,1)),U,3)["VA(200":1,1:0) IBZP=IBZP_+$P(Z(Z,1),U,3)_U
  D ALLPROC^IBCVA1(IBIFN,.IBZP1)
- S Z=0 F  S Z=$O(IBZP1(Z)) Q:'Z  I $P(IBZP1(Z),U,18),IBZP'[(U_$P(IBZP1(Z),U,18)_U) S IBOK=0 Q
+ S Z=0 F  S Z=$O(IBZP1(Z)) Q:'Z  I $P(IBZP1(Z),U,18),(U_$P(IBZP1(Z),U,18)_U)'[IBZP S IBOK=0 Q
  I 'IBOK D WARN^IBCBB11("At least one provider on a procedure does not match your "_$S(IBFT=2:"render",1:"attend")_"ing or operating provider")
  I IBFT=2 D EN^IBCBB2
@@ -37,5 +37,5 @@
 PARTA ; MEDICARE specific edit checks for PART A claims (UB-04 formats)
  ;
- N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS,REQMRA
+ N IBI,IBJ,IBX,IBCTYP,VADM,VAPA,IBSTOP,IBDXC,IBDXARY,IBPR,IBLABS
  N IBS,IBTUNIT,IBCAGE,IBREV1,IBOCCS,IBOCSDT,IBVALCD,IBOCCD,IBNOPR
  N IBCCARY1,IBPATST,IBZADMIT,IBZDISCH,IBXIEN,IBXERR,IBXDATA,IBOCSP
@@ -89,8 +89,6 @@
  ;              procedure
  ;
- S REQMRA=$$REQMRA^IBEFUNC(IBIFN)
  S (IBNOPR,IBI)=0
  F  S IBI=$O(IBXDATA(IBI)) Q:'IBI  D
- . I REQMRA D GYMODCHK(IBXDATA(IBI))      ; IB*2*377 GY modifier check
  . S IBJ=$P(IBXDATA(IBI),U),IBECAT=""
  . I 'IBNOPR D
@@ -119,4 +117,5 @@
  . ;    to be sent to MEDICARE for an MRA
  . D NONMCR(.IBPR,.IBLABS) ; Remove Oxygen, labs, influenza shots
+ . ;I $O(IBPR(""))="" D
  . I $G(IBLABS) D WARN^IBCBB11("The only possible billable procedures on this bill are labs -"),WARN^IBCBB11(" Please verify that MEDICARE does not reimburse these labs at 100%") Q
  . I $O(IBPR(""))="" D
@@ -138,15 +137,4 @@
  D DEM^VADPT
  I $P(VADM(5),U)'="M",$P(VADM(5),U)'="F" S IBQUIT=$$IBER(.IBER,124) Q:IBQUIT
- ;
- ; esg - 10/17/07 - patch 371
- ; For Part A replacement MRA request claims, make sure
- ; the Medicare ICN/DCN number is present and also text in FL-80.
- I $$REQMRA^IBEFUNC(IBIFN),$F(".137.138.117.118.","."_IBTOB_".") D  Q:IBQUIT
- . N IBZ,FL80TXT
- . D F^IBCEF("N-CURR INS FORM LOC 64","IBZ",,IBIFN)  ; see CI3-11
- . I IBZ="" S IBQUIT=$$IBER(.IBER,205) Q:IBQUIT      ; missing ICN/DCN
- . S FL80TXT=$P($G(^DGCR(399,IBIFN,"UF2")),U,3)
- . I FL80TXT="" S IBQUIT=$$IBER(.IBER,206) Q:IBQUIT  ; missing FL80 text
- . Q
  ;
  D ^IBCBB4
@@ -172,4 +160,5 @@
  F Z=77:1:85 S Z0="E13"_Z K IBPR(Z0)
  ; Labs
+ ;S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  K IBPR(Z) S IBLABS=1
  S Z="80000" F  S Z=$O(IBPR(Z)) Q:Z'?1"8"4N  S IBLABS=1
  ; Flu shots
@@ -195,13 +184,2 @@
  Q IB
  ;
-GYMODCHK(Z) ; GY modifier check procedure.  IB*2*377 - 2/4/08
- ; Z is the IBXDATA(IBI) service line EDI
- N MODS
- I IBER["IB123" Q     ; error already found
- S MODS=$P(Z,U,9)     ; list of modifiers separated by commas
- I MODS'["GY" Q       ; GY modifier not here on this line item
- I $P(Z,U,6) Q        ; non-covered charges exist on this line item
- S IBQUIT=$$IBER(.IBER,123)
-GYMODX ;
- Q
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB5.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCBB5 ;ALB/BGA - CONT OF MEDICARE EDIT CHECKS ;08/12/98
- ;;2.0;INTEGRATED BILLING;**51,137,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**51,137**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified
  ;
  D F^IBCEF("N-ADMISSION DATE","IBZADMIT",,IBIFN)
@@ -15,9 +15,6 @@
  S IBI=0 F  S IBI=$O(IBXSAVE("OCCS",IBI)) Q:'IBI  D
  . N IBOCSDT,IBOCSDT1,Z
- . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,3),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
+ . S IBOCSDT=$P(IBXSAVE("OCCS",IBI),U,2),IBOCSDT1=$P(IBXSAVE("OCCS",IBI),U,4),IBOCCS=$P(IBXSAVE("OCCS",IBI),U)
  . S IBOCSP(IBOCCS,$O(IBOCSP(IBOCCS,""),-1)+1)=IBXSAVE("OCCS",IBI)
- . ; Occurrence Code End dates must be > start date and are required for OCCURANCE SPANS
- . I 'IBOCSDT1 S IBER=IBER_"IB155;" Q
- . I IBOCSDT1<IBOCSDT S IBER=IBER_"IB150;" Q
  ;
  S IBI=0 F  S IBI=$O(IBXSAVE("OCC",IBI)) Q:'IBI  D
@@ -37,12 +34,14 @@
  S IBX=0
  F  S IBX=$O(IBXDATA(IBX)) Q:'IBX  D  Q:IBQUIT
- . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2)
  . ; value code 01 must have a value>0
- . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134) Q
+ . I $P(IBXDATA(IBX),U)="01",IBER'["134;",$P(IBXDATA(IBX),U,2)'>0 S IBQUIT=$$IBER^IBCBB3(.IBER,134)
+ . Q:IBQUIT
  . ; value code 02 must have a value=0
- . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135) Q
+ . I $P(IBXDATA(IBX),U)="02",IBER'["135;",+$P(IBXDATA(IBX),U,2)'=0 S IBQUIT=$$IBER^IBCBB3(.IBER,135)
  . ; code^amount^dollar amt flag (1=amt,0=quantity)
- . I $P(IBXDATA(IBX),U,2)="",IBER'["157;" S IBQUIT=$$IBER^IBCBB3(.IBER,157) Q
- . I '$$CHK^IBCVC($P(IBXDATA(IBX),U,4),$P(IBXDATA(IBX),U,2)),IBER'["158;" S IBQUIT=$$IBER^IBCBB3(.IBER,158) Q
+ . Q:IBQUIT
+ . I '$D(IBVALCD($P(IBXDATA(IBX),U))) S IBVALCD($P(IBXDATA(IBX),U))=$P(IBXDATA(IBX),U,2) Q
+ ; Must have value code 01 or 02 for TOB 11X, 18X, 21X - default it
+ ;I '$D(IBVALCD("01")),'$D(IBVALCD("02")),$S(IBTOB12="11":1,IBTOB12="18":1,1:IBTOB12="21") S IBQUIT=$$IBER^IBCBB3(.IBER,132)
  ;
  Q:IBQUIT
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCBB9.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCBB9 ;ALB/BGA MEDICARE PART B EDIT CHECKS ;10/15/98
- ;;2.0;INTEGRATED BILLING;**51,137,155,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -27,4 +27,11 @@
  I $S($G(IBXDATA)="":1,$E($P(IBXDATA,U))=" "!($E($P(IBXDATA,U))'?1A):1,$E($P(IBXDATA,U,2))=" "!($E($P(IBXDATA,U,2))'?1A):1,1:0) S IBQUIT=$$IBER^IBCBB3(.IBER,300) Q:IBQUIT
  ;
+ ; First char of the pat's address and city must not be a space
+ K IBXDATA D F^IBCEF("N-PATIENT STREET ADDRESS LN 1",,,IBIFN)
+ I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT
+ ;
+ K IBXDATA D F^IBCEF("N-PATIENT CITY",,,IBIFN)
+ I $G(IBXDATA)=""!($E($G(IBXDATA))=" ") S IBQUIT=$$IBER^IBCBB3(.IBER,302) Q:IBQUIT
+ ;
  ; Must be a valid HIC #
  I '$$VALID^IBCBB8(IBIFN) S IBQUIT=$$IBER^IBCBB3(.IBER,215) Q:IBQUIT
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCC1.m	(revision 636)
@@ -1,13 +1,11 @@
-IBCC1 ;ALB/MJB - CANCEL THIRD PARTY BILL ;10-OCT-94
- ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347,377**;21-MAR-94;Build 23
+IBCC1 ;ALB/MJB - CANCEL UB-82 THIRD PARTY BILL ;10-OCT-94
+ ;;2.0;INTEGRATED BILLING;**19,95,160,159,320,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
 RNB ; -- Add a reason not billable to claims tracking
  N X,Y,DIC,DIE,I,J,DA,DR,IBTYP,IBTRE,IB,IBAPPT,IBDT,IBTALK,IBCODE,IBTRED,IBTSAV,FILL,IBRX,IBDATA,IBD,IBDT,IBQUIT,IBPRO,IBDD
- N ZT,TCNT,CNT
  Q:'$G(IBIFN)
  S IB(0)=$G(^DGCR(399,IBIFN,0)),IBTYP=$P(IB(0),"^",5),IBQUIT=0
  I '$D(DFN) S DFN=$P(IB(0),"^",2)
- KILL ^TMP($J,"IBCC1")
  ;
  ; -- is inpt find entry in dgpm, then in ibt(356, s da=ibtre then edit
@@ -16,5 +14,5 @@
  .S DGPM=$O(^DGPM("APTT1",DFN,DATE,0)) ; double check for asih
  .I DGPM S (IBTRE,IBTSAV)=$O(^IBT(356,"AD",DGPM,0))
- .I $G(IBTRE) D CTSET(IBTRE)
+ .I $G(IBTRE) D RNBEDIT
  .Q:IBQUIT
  .;
@@ -23,5 +21,5 @@
  .S DATE=$P(IB(0),"^",3),DFN=$P(IB(0),"^",2)
  .S IBDT=(DATE-.25) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(DATE+.24))  D
- ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE CTSET(IBTRE)
+ ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D:$G(IBTSAV)'=IBTRE RNBEDIT
  .Q
  ;
@@ -30,5 +28,5 @@
  .S IBAPPT=0 F  S IBAPPT=$O(^DGCR(399,IBIFN,"OP",IBAPPT)) Q:'IBAPPT!(IBQUIT)  D
  ..S IBDT=(IBAPPT-.01) F  S IBDT=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT)) Q:'IBDT!(IBDT>(IBAPPT+.24))  D
- ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D CTSET(IBTRE)
+ ...S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APTY",DFN,IBCODE,IBDT,IBTRE)) Q:IBTRE=""!(IBQUIT)  D RNBEDIT
  .Q
  ;
@@ -38,5 +36,5 @@
  .I '$G(IBRX) S DIC=52,DIC(0)="BO",X=$P(IBDATA,"^",1) D DIC^PSODI(52,.DIC,X) S IBRX=+Y K DIC,X,Y Q:IBRX=-1
  .S FILL="" F  S FILL=$O(^IBT(356,"ARXFL",IBRX,FILL)) Q:FILL=""!(IBQUIT)  D
- ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT)  I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D CTSET(IBTRE)
+ ..S IBTRE=0 F  S IBTRE=$O(^IBT(356,"ARXFL",IBRX,FILL,IBTRE)) Q:'IBTRE!(IBQUIT)  I $P(^IBT(356,+IBTRE,0),"^",6)=IBDT D RNBEDIT
  ;
 PRO ; -- find prosthetics on bill
@@ -44,98 +42,23 @@
  .S IBDATA=$G(^IBA(362.5,IBD,0)),IBPRO=$P(IBDATA,"^",4)
  .Q:'$G(IBPRO)
- .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D CTSET(IBTRE)
- ;
- ; ----- Finished with the gathering of the CT data entries -----
- ;
- ; count up the total number of CT entries recorded in the scratch global
- S ZT="",TCNT=0
- F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""  S IBTRE=0 F  S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE  S TCNT=TCNT+1
- ;
- ; loop thru all of the associated CT entries and call the RNBEDIT procedure for each one
- S ZT="",CNT=0
- F  S ZT=$O(^TMP($J,"IBCC1",ZT)) Q:ZT=""!IBQUIT  D  Q:IBQUIT
- . S IBTRE=0 F  S IBTRE=$O(^TMP($J,"IBCC1",ZT,IBTRE)) Q:'IBTRE!IBQUIT  S CNT=CNT+1 D RNBEDIT(IBTRE,ZT,TCNT,CNT)
- . Q
- ;
- ; clean-up the scratch global when completed
- KILL ^TMP($J,"IBCC1")
+ .S IBTRE=0 F  S IBTRE=$O(^IBT(356,"APRO",+IBPRO,IBTRE)) Q:'IBTRE!(IBQUIT)  D RNBEDIT
  Q
  ;
-CTSET(IBTRE) ; procedure to store this CT entry in the scratch global
- Q:'$G(IBTRE)
- S ^TMP($J,"IBCC1",$$TYPE(IBTRE),IBTRE)=""
-CTSETX ;
- Q
- ;
-RNBEDIT(IBTRE,CTTYPE,TCNT,CNT) ; CT entry display and capture RNB data and additional comment data
+RNBEDIT ;
  Q:IBQUIT
- I '$D(IBTALK) D
- . N CTZ
- . W !!,"Since you have canceled this bill, you may enter a Reason Not Billable and"
- . W !,"an Additional Comment into Claims Tracking."
- . W !,"This will take the care off of the UNBILLED lists."
- . I TCNT=1 S CTZ="Note:  There is 1 associated Claims Tracking entry."
- . E  S CTZ="Note:  There are "_TCNT_" associated Claims Tracking entries."
- . W !!,CTZ
- . Q
- ;
+ W:'$D(IBTALK) !!,"Since you have canceled this bill, you may enter a Reason Not Billable",!,"into Claims Tracking.  This will take the care off of the UNBILLED lists"
  S IBTALK=1
  ;
- N %,IBTRED,IBTRED1 S IBTRED=$G(^IBT(356,IBTRE,0)),IBTRED1=$G(^IBT(356,IBTRE,1))
- ;
- W !!,"Claims Tracking Entry [",CNT," of ",TCNT,"]"
- W !?7,"Entry ID#: ",+IBTRED
- W !?12,"Type: ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,U,18))
- ;
- I CTTYPE=1 D     ; inpatient admission or scheduled admission
- . W !?2,"Admission Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
- . Q
- ;
- I CTTYPE=2 D     ; outpatient visit
- . N IBOE,IBOE0
- . W !?6,"Visit Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
- . S IBOE=+$P(IBTRED,U,4),IBOE0=$$SCE^IBSDU(IBOE)
- . W !?10,"Clinic: ",$$GET1^DIQ(44,+$P(IBOE0,U,4)_",",.01)
- . Q
- ;
- I CTTYPE=3 D     ; prescription refill
- . N PSONTALK,PSOTMP,X
- . S PSONTALK=1
- . S X=+$P(IBTRED,U,8)_U_+$P(IBTRED,U,10) D EN^PSOCPVW
- . ;if refill was deleted and EN^PSOCPVW doesn't return any data use IB API
- . I '$D(PSOTMP) D PSOCPVW^IBNCPDPC(+$P(IBTRED,U,2),+$P(IBTRED,U,8),.PSOTMP)
- . W !?3,"Prescription#: ",$G(PSOTMP(52,+$P(IBTRED,U,8),.01,"E"))
- . I '$P(IBTRED,U,10) W !?7,"Fill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
- . I $P(IBTRED,U,10) W !?5,"Refill Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
- . W !?12,"Drug: ",$G(PSOTMP(52,+$P(IBTRED,U,8),6,"E"))
- . Q
- ;
- I CTTYPE=4 D     ; prosthetic item
- . N IBDA,IBRMPR
- . S IBDA=$P(IBTRED,U,9)
- . D PRODATA^IBTUTL1(IBDA)
- . W !?3,"Delivery Date: ",$$FMTE^XLFDT($P(IBTRED,U,6),"1P")
- . W !?12,"Item: ",$G(IBRMPR(660,+IBDA,4,"E"))
- . W !?5,"Description: ",$G(IBRMPR(660,+IBDA,24,"E"))
- . Q
- ;
+ N %,IBTRED S IBTRED=$G(^IBT(356,IBTRE,0))
+ W !!,"Claims Tracking entry: ",+IBTRED,"  ",$$EXPAND^IBTRE(356,.18,$P(IBTRED,"^",18)),"  ",$$FMTE^XLFDT($P(IBTRED,"^",6))
  I $G(IBMCSRNB)'="",$P(IBTRED,U,19) W !," Note:  A Reason Not Billable has been previously entered",!?8,"for this Claims Tracking record."
- I $G(IBMCSCAC)'="",$P(IBTRED1,U,8)'="" W !," Note:  An Additional Comment has been previously entered",!?8,"for this Claims Tracking record."
- ;
  S DA=IBTRE,DIE="^IBT(356,",DR=".19"
- I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel - reason not billable
- I $G(IBMCSCAC)'="" S DR=DR_";1.08//^S X=IBMCSCAC"   ; IB*377 MCS cancel - additional comment
- I $G(IBMCSCAC)="" S DR=DR_";1.08"                   ; IB*377 additional comment field SRS 3.3.2.1
+ I $G(IBMCSRNB)'="" S DR=".19//"_$P(IBMCSRNB,U,2)    ; IB*320 MCS cancel
  D ^DIE
  ;
- ; - if the RNB or additional comment changed, update the user and date/time last edited
- I $P(IBTRED,U,19)'=$P($G(^IBT(356,IBTRE,0)),U,19)!($P(IBTRED1,U,8)'=$P($G(^IBT(356,IBTRE,1)),U,8)) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
+ ; - if the RNB changed, update the user and date/time last edited
+ I $P(IBTRED,"^",19)'=$P($G(^IBT(356,IBTRE,0)),"^",19) D NOW^%DTC S DR="1.03///"_%_";1.04////"_DUZ D ^DIE
  ;
  ; $D(Y) indicates an up-arrow exit from the DIE call (??)
  I $D(Y) S DFN=+$P(^IBT(356,IBTRE,0),"^",2) D FIND^IBOHCT(DFN,IBTRE) S IBQUIT=1
  Q
- ;
-TYPE(Z) ; function to get the type of claims tracking entry
- ; Z is the ien to file 356
- Q +$P($G(^IBE(356.6,+$P($G(^IBT(356,+Z,0)),U,18),0)),U,3)
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC2.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCCC2 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;6/6/03 9:56am
- ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**80,106,124,138,51,151,137,161,182,211,245,155,296,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -55,5 +55,5 @@
 U2 F J=1:1:19 I $P(IBND("U2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U2"),"^",J)=$P(IBND("U2"),"^",J)
  Q
-U3 F J=1:1:7 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
+U3 F J=1:1:3 I $P(IBND("U3"),"^",J)]"" S $P(^DGCR(399,IBIFN,"U3"),"^",J)=$P(IBND("U3"),"^",J)
  Q
 UF2 F J=1,3 I $P(IBND("UF2"),"^",J)]"" S $P(^DGCR(399,IBIFN,"UF2"),"^",J)=$P(IBND("UF2"),"^",J)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCCC3.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCCC3 ;ALB/AAS - CANCEL AND CLONE A BILL - CONTINUED ;25-JAN-90
- ;;2.0;INTEGRATED BILLING;**363,381,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**363,381**;21-MAR-94;Build 1
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -52,5 +52,5 @@
  ... S IBX=$G(^IBA(362.5,IBPIFN,0)) I IBX=""!($P(IBX,U,2)'=IBIFN1) Q
  ... S DIC="^IBA(362.5,",DIC(0)="L",X=$P(IBX,U,1) K DA,DO D FILE^DICN K DA,DO Q:Y'>0
- ... S DR=".02////"_IBIFN_";.04////"_$P(IBX,U,4)_";.05////^S X=$P(IBX,U,5)"
+ ... S DR=".02////"_IBIFN_";.03////"_$P(IBX,U,3)_";.04////"_$P(IBX,U,4)
  ... S DIE=DIC,DA=+Y D ^DIE K DIC,DIE,DA,DO,DR
  K DIE,DIC,DA,DO,DR,X,Y
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCE ;ALB/TMP - 837 EDI TRANSMISSION UTILITIES/NIGHTLY JOB ;22-JAN-96
- ;;2.0;INTEGRATED BILLING;**137,283,296,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,283,296**;21-MAR-94
 EN ; Run all jobs needed for EDI processing nightly
  ; including transmit bills waiting for extract, batches not sent,
@@ -44,7 +43,6 @@
  ;
 RESUB(IB364) ; Manually resubmit bill for transmission (ien file 364 = IB364)
- N DIR,X,Y,IBBTCH,DTOUT,DUOUT,IBIFN,NEW364
+ N DIR,X,Y,IBBTCH,DTOUT,DUOUT
  I '$$MGCHK(1) G RESUBQ
- S IBIFN=+$P($G(^IBA(364,+$G(IB364),0)),U,1) I 'IBIFN G RESUBQ
  S IBBTCH=""
  W ! S DIR(0)="SA^I:IMMEDIATE TRANSMIT;L:TRANSMIT LATER WITH REST OF READY FOR EXTRACT BILLS",DIR("A")="TRANSMIT (I)MMEDIATELY OR (L)ATER?: ",DIR("B")="L"
@@ -53,34 +51,27 @@
  D ^DIR K DIR
  I $D(DTOUT)!$D(DUOUT) G RESUBQ
- ;
- ; immediate retransmission of claim
- I Y="I" D  G RESUBQ
- . S NEW364=$$ADDTBILL^IBCB1(IBIFN)    ; Add a new transmission record
- . I '$P(NEW364,U,3) D  Q
- .. S DIR("A",1)="FAILED TO ADD A NEW EDI TRANSMISSION",DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
- .. Q
- . ;
+ I Y="I" D  G:'IBBTCH RESUBQ
+ . N Y
  . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
- . S ^TMP("IBONE",$J,+NEW364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)=""
+ . S ^TMP("IBONE",$J,IB364)="",^TMP("IBONE",$J)=0,^TMP("IBSELX",$J)=""
  . D ONE^IBCE837
  . S IBBTCH=$O(^TMP("IBCE-BATCH",$J,0))                     ; external batch#
  . I IBBTCH'="" S IBBTCH=+$G(^TMP("IBCE-BATCH",$J,IBBTCH))  ; internal batch#
  . K ^TMP("IBONE",$J),^TMP("IBSELX",$J),^TMP("IBCE-BATCH",$J)
- . ;
  . I 'IBBTCH D
  .. S DIR("A",1)="BILL NOT RESUBMITTED - CHECK ALERTS/MAIL FOR DETAILS"
  . E  D
  .. N DIE,DR,DA
- .. D UPDEDI^IBCEM(IB364,"R")   ; update EDI files for old transmission
+ .. D UPDEDI^IBCEM(IB364,"R")
  .. S DIE="^IBA(364,",DR=".06////"_+IBBTCH,DA=IB364 D ^DIE
- .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,+IBBTCH,0)),U,1)
- . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
- . Q
- ;
- ; Later retransmission of claim
- D UPDEDI^IBCEM(IB364,"R")      ; update EDI files for old transmission record
- S Y=$$ADDTBILL^IBCB1(IBIFN)    ; Add a new transmission record
- S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'"
- S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " W ! D ^DIR K DIR
+ .. S DIR("A",1)="BILL RESUBMITTED IN BATCH #"_$P($G(^IBA(364.1,IBBTCH,0)),U)
+ . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR
+ I Y="L" D
+ . N Y
+ . D UPDEDI^IBCEM(IB364,"R")
+ . ;Add a new transmission record
+ . S Y=$$ADDTBILL^IBCB1($P($G(^IBA(364,+IB364,0)),U),1)
+ . S DIR("A",1)="BILL'S TRANSMISSION STATUS RESET TO 'READY TO EXTRACT'"
+ . S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR
  ;
 RESUBQ Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE277.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCE277 ;ALB/TMP - 277 EDI CLAIM STATUS MESSAGE PROCESSING ;15-JUL-98
- ;;2.0;INTEGRATED BILLING;**137,155,368**;21-MAR-94;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,155**;21-MAR-94
  Q
  ; MESSAGE HEADER DATA STRING =
@@ -8,6 +7,7 @@
 HDR(ENTITY,ENTVAL,IBTYPE,IBD) ;Process header data
  ; INPUT:
- ;   ENTITY = "BATCH" or "CLAIM" for batch/claim level messages respectively
- ;   ENTVAL = claim #
+ ;   ENTITY = "BATCH" if batch level message
+ ;            "CLAIM" if claim level message
+ ;   ENTVAL = batch # or claim #
  ;   IBTYPE = the type of status msg this piece of the message represents
  ;             (837REC1, 837REJ1)
@@ -16,4 +16,5 @@
  ; OUTPUT:
  ;   IBD array returned with processed data
+ ;      "LINE" = The last line # populated in the message
  ;      "DATE" = Date/Time of status (Fileman format)
  ;      "MRA" =  1 if MRA, 0 if not         "X12" = 1 if X12, 0 if not
@@ -22,124 +23,115 @@
  ;
  ;   ^TMP("IBMSG",$J,"BATCH",batch #,0)=MESSAGE HEADER DATA STRING
- ;                                      if batch level message
+ ;                                      if called from batch level
  ;                                  ,"D",0,1)=header record raw data
  ;                                  ,line #)=batch status message lines
  ;
  ;   ^TMP("IBMSG",$J,"CLAIM",claim #,0)=MESSAGE HEADER DATA STRING
- ;                                      if claim level message
+ ;                                      if called from claim level
  ;                                  ,"D",0,1)=header record raw data
  ;                                  ,line #)=claim status message lines
  ;
- N DATA,IBD0,L,PC,X,Y
- S IBD0=$G(^TMP("IBMSGH",$J,0)) Q:IBD0=""
- S Y=0,L=1
- ; Convert claim date/time
- S X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4) I X S %DT="XTS" D ^%DT
- ; populate IBD array
- S IBD("DATE")=$S(Y>0:Y,1:""),IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X")
- S IBD("SOURCE")=$P(IBD0,U,12,13),IBD("BATCH")=$P(IBD0,U,14)
- I +$TR($P(IBD0,U,6,9),U) F PC=6:1:9 D
- .I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_"  "
- .I $L($G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)))+$L(DATA)>70 S L=L+1 ; if data doesn't fit into current line, go to the next line
- .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=$G(^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L))_DATA ; file this piece of data
- .Q
- ; file batch ref. number
- S:IBD("BATCH")'="" L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)="Batch Reference Number: "_IBD("BATCH")
- I $TR($P(IBD0,U,10,13),U)'="" D
- .S L=L+1
- .; generate and file Payer Name / Payer Id line
- .S DATA="Payer Name: "_$S($P(IBD0,U,10)'="":$P(IBD0,U,10),1:"N/A")_"  Payer ID: "_$S($P(IBD0,U,11)'="":$P(IBD0,U,11),1:"N/A")
- .S ^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA
- .I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") D
- ..; generate and file Message Source line
- ..S DATA="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")
- ..S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=DATA
- ..Q
- .Q
- S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$$GETBILL(ENTVAL)_U_U_IBD("DATE")_U_IBD("SOURCE")
- ; file raw data
+ N CT,CT1,IBBILL,IBD0,L,LINE,PC,Z,X,Y
+ S IBD0=$G(^TMP("IBMSGH",$J,0)),IBD("LINE")=0
+ Q:IBD0=""
+ S Y=0,X=$$DATE($P(IBD0,U,3))_"@"_$E($P(IBD0,U,4)_"0000",1,4)
+ I X S %DT="XTS" D ^%DT
+ S IBD("DATE")=$S(Y>0:Y,1:"")
+ S IBD("MRA")=$P(IBD0,U,5),IBD("X12")=($P(IBD0,U,2)="X")
+ S IBD("SOURCE")=$P(IBD0,U,12,13)
+ S CT=0
+ ;
+ I ENTITY="BATCH",ENTVAL'="" D  ;Only pertinent for batch level extract
+ . S IBD("BATCH")=$O(^IBA(364.1,"B",ENTVAL,0))
+ . F PC=6:1:9 D
+ .. I $P(IBD0,U,PC)'="" S DATA=$P("# Claims Submitted^# Claims Rejected^Total Charges Submitted^Total Charges Rejected",U,PC-5)_": "_$S(PC<8:+$P(IBD0,U,PC),1:$FNUMBER($P(IBD0,U,PC)/100,"",2))_"  "
+ .. I CT,$L($G(LINE(CT)))+$L(DATA)>80 S CT=CT+1
+ .. S:'CT CT=1 S LINE(CT)=$G(LINE(CT))_DATA
+ ;
+ I ENTVAL'="",$TR($P(IBD0,U,10,13),U)'="" S CT1=CT,CT=CT+1 F PC=10,11,12 D  ;Both batch, claim levels extract
+ . Q:$P(IBD0,U,PC)=""
+ . I PC<12 S LINE(CT)=$G(LINE(CT))_$P("Payer Name^Payer ID",U,PC-9)_": "_$P(IBD0,U,PC)_"  ",CT1=CT Q
+ . I $P(IBD0,U,12)'=""!($P(IBD0,U,13)'="") S:$P(IBD0,U,10)'=""!($P(IBD0,U,11)'="") CT=CT+1 S LINE(CT)="Source: "_$S($P(IBD0,U,12)="Y":"Sent by payer",$P(IBD0,U,13)'="":"Sent by non-payer ("_$P(IBD0,U,13)_")",1:"UNKNOWN")_"  "
+ ;
+ I CT D
+ . S (L,Z)=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG-H",$J,ENTITY,ENTVAL,L)=LINE(Z)
+ . ;S IBD("LINE")=$G(IBD("LINE"))+CT
+ ;
+ I ENTITY="CLAIM" D
+ . N Z0
+ . S Z0=+$O(^DGCR(399,"B",ENTVAL,0))
+ . I $G(IBD("BATCH")) S IBBILL=$O(^IBA(364,"ABABI",+$G(IBD("BATCH")),Z0,""),-1) Q
+ . S IBBILL=$$LAST364^IBCEF4(Z0)
+ S ^TMP("IBMSG",$J,ENTITY,ENTVAL,0)=IBTYPE_U_$G(IBD("MSG#"))_U_$G(IBD("SUBJ"))_U_$S(ENTITY="CLAIM":IBBILL,1:"")_U_$S(ENTITY="BATCH":ENTVAL,1:"")_U_IBD("DATE")_U_IBD("SOURCE")
+ ;
  S ^TMP("IBMSG",$J,ENTITY,ENTVAL,"D",0,1)="##RAW DATA: "_IBD0
  Q
  ;
-9(IBD) ; Process Message Header record
- ; INPUT:
- ;   IBD must be passed by reference = entire message line
- ; OUTPUT:
- ;   IBD array returned with processed data
- ;      "CLAIM" = claim #
- ;      "LINE" = last line # populated in the message
- ;
- ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines
- ;                                  ,"D",9,msg seq #)= raw data
- N ENTITY,ERR,FLD,IBCLM,IBIFN,L
- D STRTREC Q:IBCLM=""  ; if no claim/batch number, bail out
- ; make sure that we have data to file
- S ERR=$P(IBD,U,4) Q:ERR=""
- ; file error along with corresponding field number (if available)
- S L=L+1,FLD=$P(IBD,U,5),^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Error"_$S(FLD'="":" in field "_FLD,1:"")_":"
- S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=ERR
- D ENDREC(9)
- Q
- ;
-10(IBD) ; Process message data
- ; INPUT:
- ;   IBD must be passed by reference = entire message line
- ; OUTPUT:
- ;   IBD array returned with processed data
- ;      "CLAIM" = claim #
- ;      "LINE" = last line # populated in the message
- ;
- ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)= message data lines
- ;                                  ,"D",10,msg seq #)= raw data
+5(IBD) ; Process batch status data
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "LINE" = The last line # populated in the message
+ ;
+ ;   ^TMP("IBMSG",$J,"BATCH",batch #,line#)=batch status message lines
+ ;                                  ,"D",5,msg seq #)=
+ ;                                       batch status message raw data
+ ;
+ N CT,DATA,IBBTCH,IBTYPE,L,LINE,Z
+ K ^TMP("IBCONF",$J)
+ S IBBTCH=+$P(IBD,U,2)
+ S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
+ I '$D(^TMP("IBMSG",$J,"BATCH",IBBTCH)) D HDR("BATCH",IBBTCH,IBTYPE,.IBD) ;Process header data if not already done for batch
+ S CT=0,LINE(1)=""
+ S DATA=$P(IBD,U,4)
+ I DATA'="",$TR($P(IBD,U,5,7),U)'="" D
+ . Q:$G(^TMP("IBMSG",$J,"BATCH",IBBTCH))=DATA
+ . S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "
+ S ^TMP("IBMSG",$J,"BATCH",IBBTCH)=DATA
+ I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5)
+ I $P(IBD,U,6)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,6),CT=CT+1
+ I $P(IBD,U,7)'="" S:'CT CT=CT+1 S LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,7)
+ I CT D
+ . S L=$G(IBD("LINE")),Z=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"BATCH",IBBTCH,L)=LINE(Z)
+ . S ^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,$O(^TMP("IBMSG",$J,"BATCH",IBBTCH,"D",5,""),-1)+1)="##RAW DATA: "_IBD
+ . S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
+10(IBD) ; Process claim status data
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "CLAIM" = The claim #
+ ;      "LINE" = The last line # populated in the message
+ ;
+ ;   ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim status message lines
+ ;                                  ,"D",10,msg seq #)=
+ ;                                       claim status raw data
  ;   ^TMP("IBCONF",$J,claim #")="" for invalid claims within the batch
  ;
- N CODE,DATA,ENTITY,IBCLM,IBIFN,IBTYPE,L,Z
- D STRTREC Q:IBCLM=""  ; if no claim number, bail out
- S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,IBIFN)=""
+ N CT,DATA,IBCLM,IBTYPE,L,LINE,Z
+ S IBCLM=$$GETCLM($P(IBD,U,2))
+ Q:IBCLM=""
+ S:$P(IBD,U,3)="R" ^TMP("IBCONF",$J,+$O(^DGCR(399,"B",IBCLM,0)))=""
  S IBTYPE=$S($P(IBD,U,3)="R":"837REJ1",1:"837REC1")
- ;Process header data if not already done
- I '$D(^TMP("IBMSG",$J,ENTITY,IBCLM,0)) D HDR(ENTITY,IBCLM,IBTYPE,.IBD)
- I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,ENTITY,IBCLM,0)),U,1)'="837REJ1" D HDR(ENTITY,IBCLM,IBTYPE,.IBD)
- S CODE=$P(IBD,U,4) I CODE'="",$TR($P(IBD,U,5,6),U)'="" D
- .S Z=CODE_$P(IBD,U,5) I Z'=$G(IBD("SCODE")) D
- ..; determine type of status code and file it
- ..S L=L+1,DATA=$S(CODE="W":"Warning",CODE="E":"Error",1:"Informational")_" "
- ..I $P(IBD,U,5)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Code: "_$P(IBD,U,5)
- ..I $P(IBD,U,6)'="" S:$P(IBD,U,5)'="" L=L+1 S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=DATA_"Message:",L=L+1
- ..S IBD("SCODE")=Z
- ..Q
- .; file status message
- .I $P(IBD,U,6)'="" S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)=$P(IBD,U,6),L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)=" "
- .Q
- D ENDREC(10)
- Q
- ;
-13(IBD) ; Process claim data
- ; Claim must have been referenced by a previous '10' level
- ; INPUT:
- ;   IBD must be passed by reference = entire message line
- ;
- ; OUTPUT:
- ;      IBD("LINE") = The last line # populated in the message
- ;
- ;     ^TMP("IBMSG",$J,"CLAIM",claim #,line#)=claim data lines
- ;                                    ,"D",13,msg seq #)=raw data
- ;
- N CTYPE,ENTITY,IBCLM,IBIFN,L,Z1,Z2
- D STRTREC
- ; quit if no claim number or no previous 'line 10' record
- Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
- ; file clearinghouse trace number
- I $P(IBD,U,3)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Clearinghouse Trace Number: "_$P(IBD,U,3)
- ; file payer status date
- I $P(IBD,U,4)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="         Payer Status Date: "_$$DATE($P(IBD,U,4))
- ; file payer claim number
- I $P(IBD,U,5)'="" S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="        Payer Claim Number: "_$P(IBD,U,5)
- ; file split claim indicator
- I +$P(IBD,U,6)'=0 S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="               Split Claim: "_$S(+$P(IBD,U,6)=1:"No",1:"Yes ("_+$P(IBD,U,6)_" parts)")
- ; file claim type if it either doesn't match value in VistA or if it's a dental claim
- S Z1=$P(IBD,U,7),Z2=$$FT^IBCEF(IBIFN),CTYPE=$S(Z1="P"&(Z2'=2):"Professional",Z1="I"&(Z2'=3):"Institutional",Z1="D":"Dental",1:"")
- S:CTYPE'="" L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="                Claim Type: "_CTYPE
- D ENDREC(13)
+ I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR("CLAIM",IBCLM,IBTYPE,.IBD) ;Process header data if not already done for claim
+ I IBTYPE="837REJ1",$P($G(^TMP("IBMSG",$J,"CLAIM",IBCLM,0)),U,1)'="837REJ1" D HDR("CLAIM",IBCLM,IBTYPE,.IBD)
+ S CT=0,DATA=$P(IBD,U,4)
+ I DATA'="",$TR($P(IBD,U,5,7),U)'="" D
+ . Q:$G(^TMP("IBMSG",$J,"CLAIM",IBCLM))=DATA
+ . S ^TMP("IBMSG",$J,"CLAIM",IBCLM)=DATA
+ . S CT=CT+1,LINE(CT)=$G(LINE(CT))_$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "
+ I $P(IBD,U,5)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"Code: "_$P(IBD,U,5)
+ I $P(IBD,U,6)'="" S CT=$S('CT:1,1:CT),LINE(CT)=$G(LINE(CT))_"  "_$P(IBD,U,6)
+ I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,7)
+ I CT D
+ . S L=$G(IBD("LINE")),Z=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
+ . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",10,""),-1)+1)="##RAW DATA: "_IBD
+ . S IBD("LINE")=$G(IBD("LINE"))+CT
  Q
  ;
@@ -156,55 +148,57 @@
  ;                                         subscr/patient raw data
  ;
- N ENTITY,DATA,IBCLM,IBIFN,IBNM,IBNUM,IBDFN,L
- D STRTREC
- ; quit if no claim number or no previous 'line 10' record
+ N CT,Z,L,LINE,DATA,IBCLM,IBNM,IBNUM,IBDFN
+ S IBCLM=$$GETCLM($P(IBD,U,2)),CT=0,L=$G(IBD("LINE"))
  Q:$S(IBCLM="":1,1:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)))
- S IBDFN=+$P(^DGCR(399,IBIFN,0),U,2)
+ S IBDFN=+$G(^DGCR(+$O(^DGCR(399,"B",IBCLM,0)),0))
  S IBNM=$S($P(IBD,U,3)'="":$P(IBD,U,3)_","_$P(IBD,U,4)_$S($P(IBD,U,5)'="":" "_$P(IBD,U,5),1:""),1:$P($G(^DPT(IBDFN,0)),U))
  S IBNUM=$S($P(IBD,U,6)'="":$P(IBD,U,6),1:$P($G(^DPT(IBDFN,0)),U,9))
- S L=L+1,^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Patient: "_IBNM_"   "_IBNUM
+ S CT=CT+1,LINE(CT)="Patient: "_IBNM_"   "_IBNUM
  I $P(IBD,U,11) D
- .S DATA=$$DATE($P(IBD,U,11)),L=L+1
- .S ^TMP("IBMSG",$J,ENTITY,IBCLM,L)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)
- .Q
- D ENDREC(15)
- Q
- ;
-STRTREC ; start processing of the record
- ;           
- ; OUTPUT:
- ;   sets the following variables
- ;   IBCLM = claim #
- ;   ENTITY = "CLAIM" (all 277STAT messages are on claim level)
- ;   L = last populated line number
- ;
- S IBCLM=$$GETCLM($P(IBD,U,2)),ENTITY="CLAIM",L=+$G(IBD("LINE"))
- S IBIFN=+$O(^DGCR(399,"B",IBCLM,0))
- Q
- ;
-ENDREC(TYPE) ; finish processing of the record
- ; INPUT:
- ;   TYPE = record type (line type)
- ;   
- ; OUTPUT:
- ;   IBD("LINE") = is updated with last populated line number
- ;
- ;make sure all variables are set properly
- Q:$G(ENTITY)=""
- Q:$G(IBCLM)=""
- Q:$G(TYPE)=""
- ; file raw data
- S ^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,$O(^TMP("IBMSG",$J,ENTITY,IBCLM,"D",TYPE,""),-1)+1)="##RAW DATA: "_IBD
- ; update line count
- S IBD("LINE")=$G(IBD("LINE"))+L
- Q
- ;
-GETBILL(CLAIM) ; Extract transmission #
- N TRANS
- S TRANS=$$LAST364^IBCEF4(IBIFN)
- ; if status of the last transmission is "X" or "P", keep searching backwards through file 364 until record
- ; with different status is found
- I TRANS F  Q:"XP"'[$P(^IBA(364,TRANS,0),U,3)  S TRANS=$O(^IBA(364,"B",IBIFN,TRANS),-1) Q:TRANS=""  ;
- Q +TRANS
+ . S DATA=$$DATE($P(IBD,U,11)),CT=CT+1
+ . S LINE(CT)="Service Dates: "_DATA_" - "_$S($P(IBD,U,12):$$DATE($P(IBD,U,12)),1:DATA)_"  "
+ . ; Add additional lines of display data here for record 15
+ S Z=0 F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
+ S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",15,""),-1)+1)="##RAW DATA: "_IBD
+ S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
+20(IBD) ; Process service line status data
+ ; Claim must have been referenced by a previous '10' level
+ ; INPUT:
+ ;   IBD must be passed by reference = entire message line
+ ; OUTPUT:
+ ;   IBD array returned with processed data
+ ;      "LINE" = The last line # populated in the message
+ ;      "TYPE" = The msg type of status record (Confirmation/rejection)
+ ;             Note: returned if not already set at batch or claim level
+ ;
+ ;   ^TMP("IBMSG",$J,"CLAIM",claim #)=""
+ ;                                  ,line#)=service line status msg lines
+ ;                                  ,"D",20,msg seq #)=
+ ;                                       service line status raw data
+ ;
+ N CT,DATA,L,LINE,Z,IBCLM,IBLNUM
+ S IBCLM=$$GETCLM($P(IBD,U,2)),IBLNUM=$P(IBD,U,8)
+ Q:'$D(^TMP("IBMSG",$J,"CLAIM",IBCLM))
+ S CT=0
+ I IBLNUM'="" S CT=CT+1,LINE(CT)="Claim Line: "_IBLNUM,^TMP("IBMSG",$J,"LINE",IBCLM,IBLNUM)=""
+ S DATA=$P(IBD,U,4)
+ I DATA'="",$TR($P(IBD,U,5,7),U)'="" S:'CT CT=CT+1 S LINE(CT)=$S(DATA="W":"Warning",DATA="E":"Error",1:"Informational")_"  "_$G(LINE(CT))
+ S:$G(IBD("TYPE"))="" IBD("TYPE")=$S(DATA="E":"837REJ1",1:"837REC1")
+ I $P(IBD,U,5)'="" S:'CT CT=CT+1 S LINE(CT)=LINE(CT)_$P(IBD,U,5)
+ I $P(IBD,U,6)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,6)
+ I $P(IBD,U,7)'="" S CT=CT+1,LINE(CT)="  "_$P(IBD,U,7)
+ I CT D
+ . S L=$G(IBD("LINE")),Z=0
+ . F  S Z=$O(LINE(Z)) Q:'Z  S L=L+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,L)=LINE(Z)
+ . S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,$O(^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",20,""),-1)+1)="##RAW DATA: "_IBD
+ . S IBD("LINE")=$G(IBD("LINE"))+CT
+ Q
+ ;
+21(IBD) ; Process service line ID data
+ ; Moved for size too big
+ D 21^IBCE277A(IBD)
+ Q
  ;
 DATE(DT) ; Convert YYMMDD Date into MM/DD/YY or YYYYMMDD into MM/DD/YYYY
@@ -216,5 +210,7 @@
 GETCLM(X) ; Extract the claim # without site id from the data in X
  N IBCLM
- S IBCLM=$P(X,"-",2) I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X))
+ S IBCLM=$P(X,"-",2)
+ I IBCLM="",X'="" S IBCLM=$E(X,$S($L(X)>7:4,1:1),$L(X))
+ ;S IBCLM=$E(X,$L(IBCLM)-6,$L(IBCLM)) ; Only take last 7 char
  Q IBCLM
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE835.m	(revision 636)
@@ -1,6 +1,4 @@
 IBCE835 ;ALB/TMP - 835 EDI EXPLANATION OF BENEFITS MSG PROCESSING ;19-JAN-99
- ;;2.0;INTEGRATED BILLING;**137,135,155,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+ ;;2.0;INTEGRATED BILLING;**137,135,155**;21-MAR-94
  Q
  ;
@@ -71,4 +69,16 @@
  I '$D(^TMP("IBMSG",$J,"CLAIM",IBBILL)) D HDR(IBBILL,.IBD) ;Process header data if not already done for claim
  ;
+ I $P(IBD,U,7)="Y"!($P(IBD,U,8)="Y") D  ;New patient name or id reported
+ . ;
+ . ; Alert to EDI mail group that name or ID has changed
+ . N XQA,XQAMSG
+ . S XQA("G.IB EDI")=""
+ . S XQAMSG="EOB for bill # "_IBBILL_" indicates a new name or id exists for patient"
+ . D SETUP^XQALERT
+ . ;
+ . S IBD("LINE")=$G(IBD("LINE"))+1
+ . I $P(IBD,U,7)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))="New patient name: "_$P(IBD,U,3)_","_$P(IBD,U,4)_" "_$P(IBD,U,5)_"  "
+ . I $P(IBD,U,8)="Y" S ^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE"))=$G(^TMP("IBMSG",$J,"CLAIM",IBBILL,IBD("LINE")))_"New patient id: "_$P(IBD,U,6)
+ ;
  I $P(IBD,U,9) D  ;Statement dates
  . S IBD("LINE")=$G(IBD("LINE"))+1
@@ -77,21 +87,4 @@
  S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D",5,1)="##RAW DATA: "_IBD
  S ^TMP("IBMSG",$J,"CLAIM",IBBILL,"D1",1,5)="##RAW DATA: "_IBD
- Q
- ;
-6(IBD) ; Process 06 record type for corrected name and/or ID# - IB*2*377 - 1/14/08
- NEW IBCLM,Z
- S IBCLM=$$GETCLM^IBCE277($P(IBD,U,2))
- Q:IBCLM=""
- I '$D(^TMP("IBMSG",$J,"CLAIM",IBCLM)) D HDR(IBCLM,.IBD)   ;Process header data if not already done for claim
- ;
- S Z=$G(IBD("LINE"))
- I $P(IBD,U,3)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Last Name: "_$P(IBD,U,3)
- I $P(IBD,U,4)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient First Name: "_$P(IBD,U,4)
- I $P(IBD,U,5)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient Middle Name: "_$P(IBD,U,5)
- I $P(IBD,U,6)'="" S Z=Z+1,^TMP("IBMSG",$J,"CLAIM",IBCLM,Z)="Corrected Patient ID#: "_$P(IBD,U,6)
- S IBD("LINE")=Z
- ;
- S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D",6,1)="##RAW DATA: "_IBD
- S ^TMP("IBMSG",$J,"CLAIM",IBCLM,"D1",1,6)="##RAW DATA: "_IBD
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCE837A.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCE837A ;ALB/TMP - OUTPUT FOR 837 TRANSMISSION - CONTINUED ;8/6/03 10:50am
- ;;2.0;INTEGRATED BILLING;**137,191,211,232,296,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,191,211,232,296**;21-MAR-94
  ;
 UPD(MSGNUM,BATCH,CNT,BILLS,DESC,IBBTYP,IBINS) ; Upd current batch + bills w/new status
@@ -30,15 +29,4 @@
  .S DA=IBIEN,DIE="^IBA(364,",DR=".02////"_IBBATCH_";.03///P;.04///NOW" D ^DIE
  .S IBIFN=+$G(^IBA(364,IBIEN,0))
- . ;
- . ; If this claim has just been retransmitted, set the .06 field for the previous transmission entry
- . N PRVTXI,PRVTXD
- . S PRVTXI=$O(^IBA(364,"B",IBIFN,IBIEN),-1)      ; previous transmission for this claim
- . I PRVTXI D
- .. S PRVTXD=$G(^IBA(364,PRVTXI,0))
- .. I '$F(".R.E.","."_$P(PRVTXD,U,3)_".") Q                 ; prev trans must have status of "R" or "E"
- .. I $P(PRVTXD,U,7,8)'=$P($G(^IBA(364,IBIEN,0)),U,7,8) Q   ; test bill and COB must be the same
- .. S DA=PRVTXI,DIE=364,DR=".06///"_IBBATCH D ^DIE          ; update the resubmit batch number
- .. Q
- . ;
  .Q:$D(^TMP("IBRESUBMIT",$J))!($P($G(^DGCR(399,IBIFN,0)),U,13)=4)!(+$$TXMT^IBCEF4(IBIEN)=2)
  .S IBMRA=$$NEEDMRA^IBEFUNC(IBIFN)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEBUL.m	(revision 636)
@@ -1,18 +1,14 @@
 IBCEBUL ;ALB/TMP - 837 EDI SPECIAL BULLETINS PROCESSING ;19-SEP-96
- ;;2.0;INTEGRATED BILLING;**137,250,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,250**;21-MAR-94
  ;
 NOTSENT ; Check for batches in pending status (no confirmation from Austin)
  ;  from yesterday or before
- N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBTYP
+ N XMTO,XMSUBJ,XMBODY,XMDUZ,IBT,IB,IBE,IBCT,IBI,IB0,IB1,Z,IBDTM
  K ^TMP($J,"IBNOTSENT")
+ D NOW^%DTC S IBDTM=%
  S (IBCT,IBI)=0
- F  S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI  D
- . I $$BCHCHK(IBI) Q    ; Batch check function
- . S IBCT=IBCT+1
- . S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7)
- . I IBCT'>10,IBTYP'="" S ^TMP($J,"IBNOTSENT",IBTYP,IBI)=""
- . Q
- ;
+ F  S IBI=$O(^IBA(364.1,"ASTAT","P",IBI)) Q:'IBI  S IBTYP=$P($G(^IBA(364.1,IBI,0)),U,7),IBDAYS=(IBDTM-$P($G(^(1)),U,6)) I IBDAYS>1,IBDAYS'=IBDTM,$O(^IBA(364,"C",IBI,0)) D
+ .S IBCT=IBCT+1,IBCT(+IBTYP)=$G(IBCT(+IBTYP))+1
+ .I IBCT'>10 S ^TMP($J,"IBNOTSENT",IBTYP,IBI)=""
  I IBCT D
  .S IBT(1)="There are "_IBCT_" EDI batch(es) still pending Austin receipt "
@@ -20,5 +16,5 @@
  .S IBT(3)="as being received by Austin."
  .S IBT(4)=" "
- .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)="  EDI BATCHES PENDING RECEIPT report to get a list of these batches."
+ .I IBCT>10 S IBT(5)="Since there were more than 10 batches found, please run the ",IBT(6)="  EDI BATCHES WAITING FOR AUSTIN RECEIPT OVER 1-DAY report to get a list of these batches."
  .I IBCT'>10 D
  ..S IBT(5)="      BATCH #      PENDING SINCE             MAIL MESSAGE #",IBT(6)="",$P(IBT(6),"-",76)="",IBT(6)="  "_IBT(6),IBE=6
@@ -32,57 +28,6 @@
  ....S IBT(IBE)="      "_$E($P(IB0,U)_$J("",10),1,10)_"   "_$E($$FMTE^XLFDT($P(IB1,U,6),1)_$J("",20),1,20)_"      "_$P(IB0,U,4),IBE=IBE+1,IBT(IBE)=$J("",8)_$E($P(IB0,U,8),1,72)
  .S XMSUBJ="EDI BATCHES WAITING AUSTIN RECEIPT FOR OVER 1 DAY",XMBODY="IBT",XMDUZ="",XMTO("I:G.IB EDI")=""
- .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO)
+ .D SENDMSG^XMXAPI(XMDUZ,XMSUBJ,XMBODY,.XMTO,,.XMZ)
  K ^TMP($J,"IBNOTSENT")
  Q
  ;
-UPDBCH(BCHIEN) ; update the status of this batch to show A0:received in Austin
- NEW DIE,DA,DR
- S DIE=364.1,DA=+BCHIEN,DR=".02///A0"
- I $D(^IBA(DIE,DA,0)) D ^DIE
-UPDBCHX ;
- Q
- ;
-BCHCHK(BCHIEN) ; This function will check the EDI claims associated with this
- ; batch and determine if this batch has been received in Austin or not.
- ;
- ; ** This function is also called by routine IBCERP3 **
- ;
- ; Function value = 1 if we can determine that the batch was received in Austin, or
- ;                = 1 if there are no claims in this batch, or
- ;                = 1 if the batch is less than 24 hours old - too new to worry about
- ;                = 1 means don't display on report or MailMan message
- ;
- ; Function value = 0 if the batch has not yet been received in Austin
- ;                = 0 means we need to display batch on report and in MailMan message
- ;
- NEW IBEDI,IBOK,IBZ,IBIFN,IB0,AR,IBSECS
- S IBEDI=0,IBOK=1,BCHIEN=+$G(BCHIEN)
- ;
- ; if the batch transmission is still less than 24 hours old, skip this batch and get out
- S IBSECS=$$FMDIFF^XLFDT($$NOW^XLFDT,$P($G(^IBA(364.1,BCHIEN,1)),U,6),2)
- I IBSECS<86400 G BCHCHKX    ; # seconds in a day
- ;
- ; if no edi claims in this batch, update batch status and get out
- I '$O(^IBA(364,"C",BCHIEN,0)) D UPDBCH(BCHIEN) G BCHCHKX
- ;
- F  S IBEDI=$O(^IBA(364,"C",BCHIEN,IBEDI)) Q:'IBEDI  D  Q:'IBOK
- . S IBZ=$G(^IBA(364,IBEDI,0))
- . S IBIFN=+IBZ,IB0=$G(^DGCR(399,IBIFN,0))
- . I $P(IB0,U,13)=7 Q                    ; cancelled in IB
- . I $P(IBZ,U,3)'="P" Q                  ; edi claim status is not pending
- . S AR=$P($$BILL^RCJIBFN2(IBIFN),U,2)   ; AR status DBIA 1452
- . I $F(".22.26.39.","."_AR_".") Q       ; collected/closed or cancelled
- . ;
- . ; if we get to this point, then we have found an EDI claim in this batch
- . ; that is not cancelled in IB, the EDI claim status is "P", and the
- . ; AR status is not collected/closed nor cancelled in AR.  So therefore
- . ; this claim didn't get to Austin, so the batch didn't get to Austin.
- . S IBOK=0
- . Q
- ;
- ; If we find the batch has been received in Austin, then change the batch status.
- I IBOK D UPDBCH(BCHIEN)
- ;
-BCHCHKX ;
- Q IBOK
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECOB1.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCECOB1 ;ALB/CXW - IB COB MANAGEMENT SCREEN/REPORT ;14-JUN-99
- ;;2.0;INTEGRATED BILLING;**137,155,288,348,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,155,288,348**;21-MAR-94;Build 5
  ;
 BLD ; Build list entrypoint
@@ -121,5 +120,5 @@
  .. S X=""
  .. S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
- .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN)_$S($P($G(^DGCR(399,IBIFN,"TX")),U,10)=1:"*",1:""),X,"BILL")
+ .. S X=$$SETFLD^VALM1($$BN1^PRCAFN(IBIFN),X,"BILL")
  .. S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IB,U)),X,"SERVICE")
  .. S X=$$SETFLD^VALM1(IBPAT,X,"PATNM")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA1.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCECSA1 ;ALB/CXW - IB STATUS AWAITING RESOLUTION SCREEN ;28-JUL-99
- ;;2.0;INTEGRATED BILLING;**137,283,288,320,368**;21-MAR-94;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,283,288,320**;21-MAR-94
  ; DBIA for $$BN1^PRCAFN()
  ;
@@ -52,5 +51,5 @@
  . ;
  . S IBSTSMSG=$$TXT(IBDA)       ; status message text
- . S IBERR=$E(IBSTSMSG,1,60)
+ . S IBERR=$E(IBSTSMSG,1,30)
  . I IBERR="" S IBERR="-"
  . ;
@@ -151,18 +150,12 @@
  F  S LN=$O(^IBM(361,+$G(IBDA),1,LN)) Q:'LN  D  Q:STOP
  . S TX=$G(^IBM(361,IBDA,1,LN,0))
+ . I $E(TX,1,5)="Error" S TX=$E(TX,6,999)
  . S TX=$$TRIM^XLFSTR(TX)
- . ; Don't include parts added by ^IBCE277
- . Q:TX="Informational Message:"
- . Q:TX="Warning Message:"
- . Q:TX="Error Message:"
- . I $E(TX,1,27)="Clearinghouse Trace Number:" S STOP=1 Q
- . I $E(TX,1,18)="Payer Status Date:" S STOP=1 Q
- . I $E(TX,1,19)="Payer Claim Number:" S STOP=1 Q
- . I $E(TX,1,12)="Split Claim:" S STOP=1 Q
- . I $E(TX,1,11)="Claim Type:" S STOP=1 Q
  . I $E(TX,1,8)="Patient:" S STOP=1 Q
  . I $E(TX,1,14)="Service Dates:" S STOP=1 Q
  . I $E(TX,1,11)="Payer Name:" S STOP=1 Q
  . I $E(TX,1,7)="Source:" S STOP=1 Q
+ . I $E(TX,1,11)="Claim Line:" S STOP=1 Q
+ . I $E(TX,1,13)="Service Type:" S STOP=1 Q
  . I TX["HL=" S HLN=+$P(TX,"HL=",2),DELIM="HL="_HLN,TX=$P(TX,DELIM,1)_"HL= "_$P(TX,DELIM,2,9)
  . I TX["ENVOY REF: " S REFN=$E($P(TX,"ENVOY REF: ",2),1,14),DELIM="ENVOY REF: "_REFN,TX=$P(TX,DELIM,1)_"ENVOY REF: "_$P(TX,DELIM,2,9)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA3.m	(revision 636)
@@ -1,20 +1,10 @@
 IBCECSA3 ;ALB/CXW - CLAIMS STATUS AWAITING RESOLUTION REPORT ;23-JUL-99
- ;;2.0;INTEGRATED BILLING;**137,320,371,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,320**;21-MAR-94
  Q
 EN ; Report of claims status awaiting resolution
- NEW %ZIS,ZTSAVE,ZTRTN,ZTDESC,DIR,X,Y,DIRUT,DTOUT,DUOUT,DIROUT,IBRVW
- ;
  D FULL^VALM1
- W !
- S DIR(0)="YO"           ; IB*2*377 new question
- S DIR("A")="Would you like to include Review Comments with this report"
- S DIR("B")="No"
- D ^DIR K DIR
- I $D(DIRUT) Q
- S IBRVW=Y
- ;
  W !!,"You will need a 132 column printer for this report!",!
  ;
+ N %ZIS,ZTSAVE,ZTRTN,ZTDESC
  S %ZIS="QM" D ^%ZIS Q:POP
  I $D(IO("Q")) K IO("Q") D  Q
@@ -25,5 +15,4 @@
  . S ZTSAVE("IBSORTOR")=""
  . S ZTSAVE("^TMP(""IBCECSB"",$J,")=""
- . S ZTSAVE("IBRVW")=""
  . S ZTDESC="IB -Claims Status Awaiting Resolution Report" D ^%ZTLOAD K ZTSK D HOME^%ZIS
  U IO
@@ -35,10 +24,9 @@
  I '$D(^TMP("IBCECSB",$J)) D  G LISTQ
  . D HDR1 W !,"No entries found for this report"
- S IBX="" F  S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP  S IBX2="" F  S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP  S IBX3="" F  S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP  D  Q:IBSTOP
+ S IBX="" F  S IBX=$O(^TMP("IBCECSB",$J,IBX)) Q:IBX=""!IBSTOP  S IBX2="" F  S IBX2=$O(^TMP("IBCECSB",$J,IBX,IBX2)) Q:IBX2=""!IBSTOP  S IBX3="" F  S IBX3=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3)) Q:IBX3=""!IBSTOP  D
  . I 'IBFST S IBPAY=$$IBPAY(IBX,IBX2,IBX3) D HDR1 S:'IBDIV IBFST=1 Q:IBSTOP
- . S IBDA=0 F  S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP  S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D  Q:IBSTOP
- .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
- .. W $$BN1^PRCAFN(+IB),$P(IB,U,12),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
- .. I $P(IB,U,12)="*" W " ***** CSA REVIEW IN PROCESS *****",!
+ . S IBDA=0 F  S IBDA=$O(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) Q:'IBDA!IBSTOP  S IB=$G(^TMP("IBCECSB",$J,IBX,IBX2,IBX3,IBDA)) D
+ .. I ($Y+5)>IOSL D HDR1 Q:IBSTOP
+ .. W $$BN1^PRCAFN(+IB),?13,$E($P(IB,U,2),1,25),?40,$E($P(IB,U,3),1,30),?72,$P($P(IB,U,4),"~"),?78,$$DAT1^IBOUTL($P(IB,U,5)),?88,$E($P(IB,U,7),1,10),?100,"$"_$J($P(IB,U,6),0,2),?110,$P(IB,U,10),?122,$P(IB,U,11),!
  .. W " FORM TYPE: "_$P($G(^IBE(353,$P($G(^DGCR(399,+IB,0)),U,19),0)),U),!
  .. I 'IBDIV S X=" DIVISION: "_$P(IB,U,8) W X,$J(" ",40-$L(X))_"AUTHORIZING BILLER: "_$P($P(IB,U,9),"~",1),!
@@ -48,35 +36,6 @@
  ... F I=1:131:$L(X) W " "_$E(X,I,I+130),!
  ... S IBZFT=1
- ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
- ... Q
- .. Q:IBSTOP
- .. ;
- .. ; Display the Review Comments if they exist based on user choice (IB*377)
- .. I $G(IBRVW),+$O(^IBM(361,IBDA,2,0)) D  Q:IBSTOP
- ... N IBCM,IBT1,IBT0,IBD0,IBCL
- ... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
- ... W ?3,"*** Review Comments for Claim "_$$BN1^PRCAFN(+IB)_" ***",!
- ... S IBCM=0 F IBT1=0:1 S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM     ; count up # of comments
- ... S IBT0=0
- ... S IBCM=0 F  S IBCM=$O(^IBM(361,IBDA,2,IBCM)) Q:'IBCM!IBSTOP  D  Q:IBSTOP
- .... S IBT0=IBT0+1
- .... S IBD0=$G(^IBM(361,IBDA,2,IBCM,0))
- .... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
- .... W ?7,"Entered "_$$FMTE^XLFDT($P(IBD0,U,1),"5ZPM")
- .... I $P(IBD0,U,2) W " by "_$P($G(^VA(200,$P(IBD0,U,2),0)),U,1)
- .... W " ("_IBT0_" of "_IBT1_")",!
- .... S IBCL=0 F  S IBCL=$O(^IBM(361,IBDA,2,IBCM,1,IBCL)) Q:'IBCL!IBSTOP  D  Q:IBSTOP
- ..... I ($Y+3)>IOSL D HDR1 Q:IBSTOP
- ..... W ?10,$G(^IBM(361,IBDA,2,IBCM,1,IBCL,0)),!
- ..... Q
- .... Q
- ... Q
- .. ;
- .. ; Display a line break before the next claim in this report
- .. I ($Y+3)>IOSL D HDR1 Q:IBSTOP
+ ... I ($Y+5)>IOSL D HDR1 Q:IBSTOP
  .. W !
- .. Q
- . Q
- ;
  G:IBSTOP LISTQ
  I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCECSA4.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCECSA4 ;ALB/CXW - IB CLAIMS STATUS AWAITING RESOLUTION SCREEN ;5-AUG-1999
- ;;2.0;INTEGRATED BILLING;**137,155,320,371**;21-MAR-1994;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,155,320**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 SMSG ;select message
@@ -14,5 +14,4 @@
  . D UNLOCK^IBCEU0(361,$P(IBA,U,2))
 SMSGQ S VALMBCK="R"
- I $G(IBFASTXT) S VALMBCK="Q" K IBDAX
  D:$O(IBDAX(0)) BLD^IBCECSA1
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
- ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -39,5 +39,5 @@
  S:$G(IBCOB)="" IBCOB=""
  I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
- S IBI=+$$POLICY(IBIFN,16,IBCOB)     ; pt relationship to insured
+ S IBI=+$$POLICY(IBIFN,16,IBCOB)
  S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
  I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
@@ -48,15 +48,9 @@
 INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
  S A=$G(^DPT(DFN,.312,+A,3))
- I $TR($P(IBADDR,U)," ")="" D PI3
- I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3
+ I $TR($P(IBADDR,U)," ")="" D
+ .S $P(IBADDR,U)=$P(A,U,6)_" "_$P(A,U,7),$P(IBADDR,U,5,6)=$P(A,U,6,7)
+ .F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
+ .S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
  Q IBADDR
- ;
-PI3 ; build IBADDR string from patient insurance 3 node data
- S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7)
- S $P(IBADDR,U,5,6)=$P(A,U,6,7)
- F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
- S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
- S $P(IBADDR,U,7)=""   ; no street address 3 in file 2.312
- Q
  ;
 PTADDR(IBIFN,ELE) ;Return part of patient's permanent address
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF1 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
- ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,124,51,137,210,155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -183,16 +183,10 @@
  . ;       address that shows through the envelope window.
  . ;
- . ; esg - 9/13/07 - IB*2*371 - Line 1 of this box contains the print
- . ;       status (i.e. copy, 2nd notice, 3rd notice, MRA needed).
- . ;
- . N Z,Z1,LM,Q,ADDR,X,IBPSTAT
+ . N Z,LM,Q,ADDR,X
  . S LM=$P($G(^IBE(350.9,1,1)),U,31)   ; UB address column parameter
  . S Z=""
  . I LM S $P(Z," ",LM)=""              ; beginning spaces indent
  . S ADDR=$G(IBXSAVE("CADR"))          ; address data string
- . ;
- . D F^IBCEF("N-PRINT BILL SUBMIT STATUS","IBPSTAT",,+$G(IBXIEN))
- . S Z1=Z I Z1="" S Z1=" "     ; line 1 can't start in column 1
- . S IBXDATA(1)=Z1_$G(IBPSTAT),Q=1             ; line 1 print status
+ . S IBXDATA(1)="",Q=1                 ; line 1 is blank
  . S Q=Q+1
  . S IBXDATA(Q)=Z_$G(IBXSAVE("CADR_NAME"))     ; line 2 payer name
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF11.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF11 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS - CONT ;30-JAN-96
- ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,155,309,335,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -82,21 +82,8 @@
  K IBRX
  ;
- ; for EDI, remove any $0 line items from the IBFLD array before 
- ; dropping down into the next loop (IB*2*371)
- I '$G(IBPRINT) D
- . NEW IBZ,IBI,Z
- . M IBZ=IBFLD K IBFLD
- . S (IBI,Z)=0
- . F  S IBI=$O(IBZ(24,IBI)) Q:IBI'=+IBI  D
- .. I $P(IBZ(24,IBI),U,7)*$P(IBZ(24,IBI),U,8)'>0 Q
- .. S Z=Z+1
- .. M IBFLD(24,Z)=IBZ(24,IBI)
- .. S IBFLD(24)=Z
- .. Q
- . Q
- ;
  S IBI=0
  F  S IBI=$O(IBFLD(24,IBI)) Q:IBI'=+IBI  D
  . S IBRX1=0
+ . I '$G(IBPRINT) Q:$P(IBFLD(24,IBI),U,7)*$P(IBFLD(24,IBI),U,8)'>0  ; For EDI, ignore 0-charge line items
  . S IBXDATA(IBI)=$P(IBFLD(24,IBI),U)_U_$P(IBFLD(24,IBI),U,$S($P(IBFLD(24,IBI),U,2)=""&'$G(IBPRINT):1,1:2))
  . S $P(IBXDATA(IBI),U,3,5)=$P(IBFLD(24,IBI),U,3,5)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF21.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCEF21 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS CONTINUED ;06-FEB-96
- ;;2.0;INTEGRATED BILLING;**51,296,371,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**51,296**;21-MAR-94
  ;
 COID(IBIFN) ; Claim office ID
@@ -40,5 +39,5 @@
  D SET^IBCSC5B(IBIFN,.IBARRAY)
  I $P($G(IBARRAY),U,2) D  ;Prosthetics
- . S Z0=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
+ . S Z0=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)="Prosthetic: "_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)_" "_$E(Z0,4,5)_"/"_$E(Z0,6,7)_"/"_$E(Z0,1,2)
  Q
  ;
@@ -78,72 +77,2 @@
  Q
  ;
-INSSECID(IBIFN,TYPE,SEQ) ; Extract subscriber and patient prim/sec ID's
- ; IBIFN required
- ; TYPE is either "PAT" or "SUB" to indicate we need to extract either
- ;          patient or subscriber ID information.  Default="SUB".
- ; SEQ is the insurance sequence# (1,2,3).  Default is current ins seq#.
- ;
- ; Output:
- ; Function returns an 8-piece string as follows.
- ;   [1] primary qualifier
- ;   [2] primary ID
- ;   [3] secondary qual(1)
- ;   [4] secondary ID(1)
- ;   [5] secondary qual(2)
- ;   [6] secondary ID(2)
- ;   [7] secondary qual(3)
- ;   [8] secondary ID(3)
- ;
- NEW DATA,DFN,POL,IB0,IB5,REL
- S DATA=""
- S IBIFN=+$G(IBIFN) I 'IBIFN G INSSX
- I $G(TYPE)="" S TYPE="SUB"               ; default type of ID's to get
- I '$F(".PAT.SUB.","."_TYPE_".") G INSSX
- I '$G(SEQ) S SEQ=$$COBN^IBCEF(IBIFN)     ; default current ins seq#
- I '$F(".1.2.3.","."_SEQ_".") G INSSX
- S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2) I 'DFN G INSSX
- S POL=+$P($G(^DGCR(399,IBIFN,"M")),U,SEQ+11) I 'POL G INSSX
- S IB0=$G(^DPT(DFN,.312,POL,0)) I IB0="" G INSSX
- S IB5=$G(^DPT(DFN,.312,POL,5))
- S REL=+$P(IB0,U,16)                      ; pat rel to insured
- S $P(DATA,U,1)="MI"
- S $P(DATA,U,2)=$P(IB0,U,2)               ; subscriber primary ID
- S $P(DATA,U,3,8)=$P(IB5,U,2,7)           ; subscriber secondary data
- I TYPE="PAT",REL'=1 D
- . S $P(DATA,U,2)=$P(IB5,U,1)             ; patient primary ID
- . S $P(DATA,U,3,8)=$P(IB5,U,8,13)        ; patient secondary data
- . Q
- ;
- S DATA=$$SCRUB(DATA)     ; scrub the data
-INSSX ;
- Q DATA
- ;
-SCRUB(DATA) ; Scrub the 8-piece string gathered above
- NEW PCE
- ;
- ; make sure you can't have an ID without a qualifier or a qualifier
- ; without an ID.  Check all 4 pairs.
- F PCE=1,3,5,7 D
- . I $P(DATA,U,PCE)'="",$P(DATA,U,PCE+1)'="" Q
- . S ($P(DATA,U,PCE),$P(DATA,U,PCE+1))=""
- . Q
- ;
- ; fill in secondary gaps.  If Set1 and Set2 are blank, but Set3 exists
- ; then move Set3 to Set1 and delete Set3.
- I $P(DATA,U,3)="",$P(DATA,U,5)="",$P(DATA,U,7)'="" D
- . S $P(DATA,U,3)=$P(DATA,U,7),$P(DATA,U,4)=$P(DATA,U,8)
- . S ($P(DATA,U,7),$P(DATA,U,8))=""
- . Q
- ;
- ; fill in secondary gaps more generically.
- ; If Set(n) is blank, but Set(n+1) exists, then move it up.
- F PCE=3,5 D
- . I $P(DATA,U,PCE)="",$P(DATA,U,PCE+2)'="" D
- .. S $P(DATA,U,PCE)=$P(DATA,U,PCE+2)
- .. S $P(DATA,U,PCE+1)=$P(DATA,U,PCE+3)
- .. S ($P(DATA,U,PCE+2),$P(DATA,U,PCE+3))=""
- .. Q
- . Q
- ;
- Q DATA
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF22.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF22 ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;06-FEB-96
- ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**51,137,135,155,309,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -122,5 +122,5 @@
  .. S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)="PROSTHETIC REFILLS:",IBLCNT=2
  .. S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
- ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54)
+ ... S IBLCNT=IBLCNT+1,IBXSAVE("PROS-UB-04",IBLCNT)=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54)
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF3.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF3 ;ALB/TMP - FORMATTER SPECIFIC BILL FLD FUNCTIONS ;17-JUNE-96
- ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**52,84,121,51,152,210,155,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -122,7 +122,7 @@
  S Z="",CT=0
  F  S Z=$O(IBARRAY(Z)) Q:Z=""  S Z0="" F  S Z0=$O(IBARRAY(Z,Z0)) Q:Z0=""  S CT=CT+1 D
- .S PROS=$$PINB^IBCSC5B(+IBARRAY(Z,Z0)) ; P389 removed p2 - item ptr file 661
- .;date^^short descr^entry # in file 362.5
- .S IBXDATA(CT)=Z_U_U_PROS_U_+IBARRAY(Z,Z0)
+ .S PROS=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+IBARRAY(Z,Z0),0)),U,3)),U,2)
+ .;date^item ptr file 661^short descr from file 441^entry # in file 362.5
+ .S IBXDATA(CT)=Z_U_Z0_U_PROS_U_+IBARRAY(Z,Z0)
 PROSQ Q CT
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
- ;;2.0;INTEGRATED BILLING;**232,320,358,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**232,320,358,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -174,5 +174,5 @@
  D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
  S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
- S IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
+ S IBZ=$$RELATION^IBCEFG1(IBZ)
  I IBZ'="18" S IBXDATA="" Q
  N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
@@ -227,11 +227,4 @@
  . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
  . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
- ; if nothing found yet, look in file 355.93 for Facility Default ID
- I IBID="",IBPROV["IBA(355.93" D
- .N IB0,IBFID,IBQ
- .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1)  ; not a facility - bail out
- .S IBFID=$P(IB0,U,9) Q:IBFID=""  ; no default id on file - bail out
- .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID
- .Q
  Q $$NOPUNCT^IBCEF(IBID)
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF73A.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF73A ;ALB/KJH - FORMATTER AND EXTRACTOR SPECIFIC (NPI) BILL FUNCTIONS ; 30 Aug 2006  10:38 AM
- ;;2.0;INTEGRATED BILLING;**343,374,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
  ;; Per VHA Directive 10-93-142, this routine should not be modified.
  ;
@@ -104,5 +104,4 @@
  I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U,3)=NPI
  I NPI<1,$D(IBNONPI) S IBNONPI=$S(IBNONPI="":3,1:IBNONPI_U_3)
- I $$ISRX^IBCEF1(IBIEN399) S IBORG=$$RXSITE(IBIEN399) I IBORG S NPI=$P($$NPI^XUSNPI("Organization_ID",IBORG),U) S:NPI'=-1 $P(IBRETVAL,U,3)=NPI
  Q IBRETVAL
  ;
@@ -129,29 +128,2 @@
  I '$L(TAX),$D(IBNOTAX) S IBNOTAX=$S(IBNOTAX="":3,1:IBNOTAX_U_3)
  Q IBRETVAL
- ;
-RXSITE(IBIEN399,IBLIST) ; returns prescription organization (file 4) pointer
- ; for the given bill.  If IBLIST passed by reference, then a list of
- ; the possible organizations are returned for a bill, since a bill may
- ; have more than one prescription.  If more than one rx on the bill, the
- ; $$ return is the pointer of the last prescription found.
- ; IBLIST(rx ien,fill date)=ORGINATION (file 4 pointer)
- ;
- N IBX,IBDATA,IBORG,IBRX,IBDT,IBY,IBRXN,DFN
- K ^TMP($J,"IBCEF73A")
- S IBORG=0,DFN=$P($G(^DGCR(399,IBIEN399,0)),"^",2),IBLIST="IBCEF73A"
- S IBRXN=0 F  S IBRXN=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN)) Q:'IBRXN  S IBX=0 F  S IBX=$O(^IBA(362.4,"AIFN"_IBIEN399,IBRXN,IBX)) Q:'IBX  D
- . S IBDATA=$G(^IBA(362.4,IBX,0))
- . S IBRX=$P(IBDATA,"^",5),IBDT=$P(IBDATA,"^",3) Q:'IBRX!('IBDT)
- . D RX^PSO52API(DFN,IBLIST,IBRX,,"0,2,R")
- . I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,22)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,20))) Q
- . S IBY=0 F  S IBY=$O(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY)) Q:'IBY  I IBDT=+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,.01)) S (IBORG,IBLIST(IBRX,IBDT))=$$PSONPI(+$G(^TMP($J,"IBCEF73A",DFN,IBRX,"RF",IBY,8))) Q
- K ^TMP($J,"IBCEF73A")
- Q IBORG
- ;
-PSONPI(IB59IEN) ; returns institution ien for a file 59 ien
- N IB4IEN
- K ^TMP($J,"IBCEF59")
- D PSS^PSO59(IB59IEN,,"IBCEF59")
- S IB4IEN=+$G(^TMP($J,"IBCEF59",IB59IEN,101))
- K ^TMP($J,"IBCEF59")
- Q IB4IEN
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF74A.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEF74A ;ALB/ESG - Provider ID maint ?ID continuation ;7 Mar 2006
- ;;2.0;INTEGRATED BILLING;**320,343,349,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**320,343,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -35,5 +35,4 @@
  S IBXIEN=IBIFN
  D F^IBCEF("N-RENDERING INSTITUTION","IBZ",,IBIFN)
- I $$ISRX^IBCEF1(IBIFN) S Z=$$RXSITE^IBCEF73A(IBIFN) I Z S $P(IBZ,"^")=+Z
  S FACNAME=$$GETFAC^IBCEP8(+IBZ,+$P(IBZ,U,2),0,"SUB")
  S Z="LAB/FAC"
@@ -54,5 +53,5 @@
  ; PRXM/KJH - Add NPI to display for patch 343.
  S ORGNPI=$$ORGNPI^IBCEF73A(IBIFN)
- S DATA=$S($$ISRX^IBCEF1(IBIFN):$P(ORGNPI,U,3),$P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3))
+ S DATA=$S($P($G(IBZ),U,2)=1:$P(ORGNPI,U,2),$P($G(IBZ),U,2)=0:$P(ORGNPI,U,1),1:$P(ORGNPI,U,3))
  I ($Y+5)>IOSL S IBQUIT=$$NOMORE^IBCEF74() I IBQUIT G EX
  W !?5,"Lab or Facility NPI:"
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEF75.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
- ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-94
+ ;; Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  G AWAY
@@ -66,5 +66,5 @@
  ; Secondary #2
  ; If there is a ID  send with quailifer (stored or computed)
- I $TR($P(M1,U,COB+1)," ")]"" D
+ I $P(M1,U,COB+1)]"" D
  . S QUAL=""
  . S DAT=$P(M1,U,COB+9)
@@ -74,5 +74,5 @@
  . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP)
  ;
- I $TR($P(M1,U,COB+1)," ")="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
+ I $P(M1,U,COB+1)="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
  ;
  S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEFG1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEFG1 ;ALB/TMP - OUTPUT FORMATTER DATA DEFINITION UTILITIES ;18-JAN-96
- ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**52,51,137,181,197,232,288,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -86,6 +86,6 @@
  ; the decimal and commas.
  N DOLR,CENT
- I AMT'="" S AMT=$TR(AMT,","),DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
- Q AMT
+ I AMT'="" S DOLR=$P(AMT,"."),CENT=$E($P(AMT,".",2)_"00",1,2),AMT=DOLR_CENT
+ Q $TR(AMT,",")
  ;
 STATE(CODE) ;Return state code from state pointer
@@ -95,4 +95,11 @@
  ; CODE = DHCP code for sex
  Q $S(CODE="":"U","MF"[$E(CODE):$E(CODE),1:"U")
+ ;
+RELATION(CODE) ;Return the X12 code for relationship
+ ; CODE = DHCP code for relationship
+ N X12
+ S X12=""
+ S:CODE'="" X12=$P($S(CODE="01":"18^SELF",CODE="02":"01^SPOUSE",CODE="03":"19^NATURAL CHILD",CODE="08":"20^EMPLOYEE",CODE="32":"32^MOTHER",CODE="33":"33^FATHER",CODE="11":"39^ORGAN DONOR",CODE="15":"41^INJURED PLAINTIFF",1:""),U)
+ Q X12
  ;
 EMPLST(CODE) ;Return the X12 code for employment status
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCEM ;ALB/TMP - 837 EDI RETURN MESSAGE PROCESSING ;17-APR-96
- ;;2.0;INTEGRATED BILLING;**137,191,155,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,191,155**;21-MAR-94
  Q
  ;
@@ -88,5 +87,5 @@
  ;
  S IBTEXT(1)=" UPDATED BY: "_$$EXTERNAL^DILFD(361.02,.02,,+$G(DUZ))
- S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
+ S IBTEXT(2)="ACTION USED: "_$S(FUNC="E":"BILL EDITED/RESUBMITTED",FUNC="C":"BILL CANCELED",FUNC="R":"BILL RESUBMITTED WITHOUT EDIT)",FUNC="P":"PRINT BILL",FUNC="Z":"PROCESS COB",1:"")
  S IBTEXT(2)=$S(IBTEXT(2)="":"UNSPECIFIED",1:IBTEXT(2)_" - REVIEW MARKED AS COMPLETE")
  S IBTEXT=2
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEM4.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCEM4 ;ALB/TMP - IB ELECTRONIC MESSAGE SCREEN TEXT MAINT ;19-APR-2001
- ;;2.0;INTEGRATED BILLING;**137,368**;21-MAR-1994;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 EN ; entry point for maintenance
@@ -60,7 +60,7 @@
  ;
  N T,Y,Z,Z0
- S (IBREV,Y)=0,Z="",IBTEXT=$$UP^XLFSTR($G(IBTEXT))
- I '$G(IBSKIP) F  S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z=""  I IBTEXT[$$UP^XLFSTR(Z) S IBREV=1 Q  ; Always review messages with this text
- I 'IBREV S Z="" F  S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z=""  I IBTEXT[$$UP^XLFSTR(Z) S Y=1,IBNR=Z Q  ; Message contains text to make review unnecessary
+ S (IBREV,Y)=0,Z=""
+ I '$G(IBSKIP) F  S Z=$O(^IBE(361.3,"AC",1,Z)) Q:Z=""  I IBTEXT[Z S IBREV=1 Q  ; Always review messages with this text
+ I 'IBREV S Z="" F  S Z=$O(^IBE(361.3,"AC",0,Z)) Q:Z=""  I IBTEXT[Z S Y=1,IBNR=Z Q  ; Message contains text to make review unnecessary
  Q Y
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEMCA2.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCEMCA2 ;ALB/ESG - Multiple CSA Message Management - Actions ;20-SEP-2005
- ;;2.0;INTEGRATED BILLING;**320,377**;21-MAR-1994;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  Q
@@ -7,5 +7,5 @@
 CANCEL ; mass claim cancel
  NEW NS,IBIFN,NSC,DIR,X,Y,DUOUT,DTOUT,DIRUT,DIROUT,IBDA,IB364,DISP,IBCE
- NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN,IBMCSCAC
+ NEW IBMCSRSC,IBMCSRNB,IBMCSCNT,IBMCSTOT,IBMCSTOP,IBMCSCAN,MRACHK,IBCAN
  D FULL^VALM1
  ;
@@ -28,7 +28,6 @@
  W !!,"In order to cancel "
  W $S(NSC=1:"this claim",1:"these claims")
- W ", a Reason Cancelled and a Reason Not Billable"
- W !,"are required.  You may also provide an optional CT Additional Comment."
- W !,"These will be used as the default responses for "
+ W ", you must supply the Reason Cancelled and"
+ W !,"the Reason Not Billable.  These will be the default responses for "
  W $S(NSC=1:"this claim",1:"all claims")
  W "."
@@ -51,12 +50,4 @@
  I $D(DIRUT) G CANCELX
  M IBMCSRNB=Y           ; save the reason not billable code/desc
- ;
-CANQ3 ; reader call for the Claims Tracking Additional Comment field
- W !
- S DIR(0)="356,1.08O"
- S DIR("A")="CT Additional Comment"
- D ^DIR K DIR
- I $D(DIRUT) G CANCELX
- M IBMCSCAC=Y
  ;
  W !
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB.m	(revision 636)
@@ -1,6 +1,4 @@
 IBCEOB ;ALB/TMP - 835 EDI EOB MESSAGE PROCESSING ;20-JAN-99
- ;;2.0;INTEGRATED BILLING;**137,135,265,155,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+ ;;2.0;INTEGRATED BILLING;**137,135,265,155**;21-MAR-94
  Q
  ;
@@ -24,5 +22,5 @@
  ; Duplicate EOB Check
  S IBFILE="^IBA(364.2,"_IBTDA_",2)"
- I $$DUP(IBFILE,X) D DELMSG^IBCESRV2(IBTDA) G UPDQ
+ I $$DUP(IBFILE,X) G UPDQ
  ;
  I '$$LOCK^IBCEM(IBTDA) G UPDQ ;Lock msg file 364.2
@@ -50,40 +48,19 @@
 5(IB0,IBEGBL,IBEOB) ; Record '05'
  ;
- N IBOK,DA,DR,DIE,X,Y
+ N IBOK,IBBULL,DA,DR,DIE,X,Y
  K IBZDATA
  S DR=";",IBOK=1
  S DIE="^IBM(361.1,",DA=IBEOB
  ;
- I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"         ; statement start date
- I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"      ; statement end date
+ S IBBULL=""
+ I $$UPDNM^IBCEOB00(IBEOB,IB0,.IBBULL,.DR)!$$UPDID^IBCEOB00(IBEOB,IB0,.IBBULL,.DR) D  ; New insured's name and/or HIC # found
+ . D CHGBULL^IBCEOB3(IBEOB,IBBULL) ;Send a bulletin reporting change
+ ;
+ I $P(IB0,U,9) S DR=DR_"1.1///"_$$DATE^IBCEU($P(IB0,U,9))_";"
+ I $P(IB0,U,10) S DR=DR_"1.11///"_$$DATE^IBCEU($P(IB0,U,10))_";"
  S DR=$P(DR,";",2,$L(DR,";")-1)
  I DR'="" D ^DIE S IBOK=$D(Y)=0
  I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 5 data"
  Q IBOK
- ;
-6(IB0,IBEGBL,IBEOB) ; Record '06' - corrected patient name and/or ID#
- ; This data is not going to be filed into file 361.1 so the value of this function will always be a 1 so as to
- ; not interrupt the filing process of the EOB/MRA data into file 361.1.
- ;
- ; perform overall integrity checks on the incoming 06 record.  If anything is out of place, don't update anything
- ; and report the problem and get out.
- NEW CLM,SITE,IBM,IBIFN,IBIFN1,DFN,SEQ,DIE,DA,DR
- S DIE=361.1,DA=IBEOB,DR="61.01////^S X=IB0" D ^DIE    ; archive the raw 06 record data
- S CLM=$P(IB0,U,2),SITE=+CLM,CLM=$P(CLM,"-",2) I CLM="" D MSG(IBEOB,"The claim# in piece 2 is invalid.") G Q6
- S IBM=$G(^IBM(361.1,IBEOB,0))
- I $P(IBM,U,4)'=1 D MSG(IBEOB,"This is a non-Medicare EOB.") G Q6
- S IBIFN=+$P(IBM,U,1)                    ; claim# from MRA
- S IBIFN1=+$O(^DGCR(399,"B",CLM,""))     ; claim# from 06 record
- I IBIFN'=IBIFN1 D MSG(IBEOB,"Claim mismatch error."_IBIFN_","_IBIFN1_","_CLM_".") G Q6
- I $P($$SITE^VASITE,U,3)'=SITE D MSG(IBEOB,"Invalid station# mismatch."_$P($$SITE^VASITE,U,3)_","_SITE_".") G Q6
- S SEQ=$$COBN^IBCEF(IBIFN)               ; current payer sequence# on claim
- I '$$WNRBILL^IBEFUNC(IBIFN,SEQ) D MSG(IBEOB,"The current payer on this claim is not MEDICARE (WNR).") G Q6
- S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)   ; patient ien
- I 'DFN D MSG(IBEOB,"The patient DFN cannot be determined.") G Q6
- ;
- D UPD^IBCEOB01(IB0,IBEOB,IBIFN,DFN,SEQ)     ; update patient insurance policy data
- ;
-Q6 ; exit point for $$6 function
- Q 1
  ;
 10(IB0,IBEGBL,IBEOB) ; Record '10'
@@ -106,6 +83,26 @@
  ;
 15(IB0,IBEGBL,IBEOB) ; Record '15'
- ; Moved due to space constraints
-Q15 Q $$15^IBCEOB00(IB0,IBEGBL,IBEOB)
+ ;
+ N A,IBOK
+ ;
+ S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
+ ;
+ S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
+ I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
+ ;
+ ; For Medicare MRA's only:
+ ; If the Covered Amount is present (15 record, piece 3), then file
+ ; a claim level adjustment with Group code=OA, Reason code=AB3.
+ ;
+ I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
+ . N IB20
+ . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
+ . S IB20=IB20_U_"Covered Amount"
+ . S IBOK=$$20(IB20,IBEGBL,IBEOB)
+ . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
+ . K ^TMP($J,20)
+ . Q
+ ;
+Q15 Q IBOK
  ;
 17(IB0,IBEGBL,IBEOB) ; Record '17'
@@ -117,6 +114,38 @@
  ;
 20(IB0,IBEGBL,IBEOB) ; Record '20'
- ; Moved due to space constraints
-Q20 Q $$20^IBCEOB00(IB0,IBEGBL,IBEOB)
+ ;
+ N A,LEVEL,IBGRP,IBDA,IBOK
+ ;
+ S IBGRP=$P(IB0,U,3)
+ I IBGRP'="" S ^TMP($J,20)=IBGRP
+ I IBGRP="" S IBGRP=$G(^TMP($J,20))
+ I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
+ ;
+ S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
+ ;
+ I 'IBDA(1) D  ;Needs a new entry at group level
+ . N X,Y,DA,DD,DO,DIC,DLAYGO
+ . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
+ . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
+ . S X=IBGRP
+ . D FILE^DICN K DIC,DO,DD,DLAYGO
+ . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
+ . S IBDA(1)=+Y
+ ;
+ I $G(IBDA(1)) D  ;Add a new entry at the reason code level
+ . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
+ . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
+ . S X=$P(IB0,U,4)
+ . D FILE^DICN K DIC,DO,DD,DLAYGO
+ . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
+ . S IBDA=+Y
+ ;
+ I $G(IBDA) D
+ . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
+ . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
+ . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
+ . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
+ . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
+Q20 Q $G(IBOK)
  ;
 30(IB0,IBEGBL,IBEOB) ; Record '30'
@@ -157,17 +186,4 @@
  D 45^IBCEOB0(IB0,IBEOB,.IBOK)
  Q $G(IBOK)
- ;
-MSG(IBEOB,MSG) ; procedure to file message into field 6.03
- ; Results of processing of the "06" record type
- N DIE,DA,DR,Z
- S DIE=361.1,DA=+$G(IBEOB)
- I $G(MSG)="" G MSGX
- S Z=$P($G(^IBM(361.1,DA,6)),U,3)    ; already existing message
- I Z'="" S MSG=Z_"  "_MSG            ; append new message to existing message
- S MSG=$E(MSG,1,190)
- S DR="6.03///^S X=MSG"
- D ^DIE
-MSGX ;
- Q
  ;
 DOLLAR(X) ; Convert value in X to dollar format XXX.XX
@@ -182,5 +198,5 @@
  ; IBFILE = array reference of raw EOB data
  ;
- N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS,MMI
+ N DIC,DA,DR,DO,DD,DLAYGO,Y,REVSTAT,BS
  F  L +^IBM(361.1,0):10 Q:$T
  ;
@@ -188,8 +204,7 @@
  S BS=$P($G(^DGCR(399,X,0)),U,13)   ; bill status
  S REVSTAT=$S(BS=7:9,BS=3:3,BS=4:3,1:0)
- S MMI=$$NET^XMRENT(IBMNUM)         ; MailMan header info
  S DIC(0)="L",DIC="^IBM(361.1,",DLAYGO=361.1
  S DIC("DR")=".16////"_REVSTAT_";.17////0"_";100.02////"_IBMNUM_$S('$G(IBAR):";.19////"_+IBTBILL_";100.01////"_IBBATCH,1:"")
- S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)_";62.01////^S X=MMI"
+ S DIC("DR")=DIC("DR")_";100.05////"_$$CHKSUM^IBCEMU1(IBFILE)
  D FILE^DICN
  L -^IBM(361.1,0)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEOB00.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEOB00 ;ALB/ESG - 835 EDI EOB MSG PROCESSING CONT ;30-JUN-2003
- ;;2.0;INTEGRATED BILLING;**155,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**155,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  Q
@@ -94,64 +94,4 @@
 ICNX ;
  Q
- ;
-15(IB0,IBEGBL,IBEOB) ; Record '15'
- ;
- N A,IBOK
- ;
- S A="3;1.03;1;0;0^4;1.04;1;0;0^5;1.05;1;0;0^6;1.07;1;0;0^7;1.08;1;0;0^8;1.09;1;0;0^9;1.02;1;0;0^10;2.05;1;0;0"
- ;
- S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB)
- I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad record 15 data" G Q15
- ;
- ; For Medicare MRA's only:
- ; If the Covered Amount is present (15 record, piece 3), then file
- ; a claim level adjustment with Group code=OA, Reason code=AB3.
- ;
- I $P($G(^IBM(361.1,IBEOB,0)),U,4)=1,+$P(IB0,U,3) D
- . N IB20
- . S IB20=20_U_$P(IB0,U,2)_U_"OA"_U_"AB3"_U_$P(IB0,U,3)_U_"0000000000"
- . S IB20=IB20_U_"Covered Amount"
- . S IBOK=$$20(IB20,IBEGBL,IBEOB)
- . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Could not file the OA-AB3 claim level adjustment for the Covered Amount"
- . K ^TMP($J,20)
- . Q
- ;
-Q15 Q IBOK
- ;
-20(IB0,IBEGBL,IBEOB) ; Record '20'
- ;
- N A,LEVEL,IBGRP,IBDA,IBOK
- ;
- S IBGRP=$P(IB0,U,3)
- I IBGRP'="" S ^TMP($J,20)=IBGRP
- I IBGRP="" S IBGRP=$G(^TMP($J,20))
- I IBGRP="" S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Missing claim level adjustment group code" G Q20
- ;
- S IBDA(1)=$O(^IBM(361.1,IBEOB,10,"B",IBGRP,0))
- ;
- I 'IBDA(1) D  ;Needs a new entry at group level
- . N X,Y,DA,DD,DO,DIC,DLAYGO
- . S DIC="^IBM(361.1,"_IBEOB_",10,",DIC(0)="L",DLAYGO=361.11,DA(1)=IBEOB
- . S DIC("P")=$$GETSPEC^IBEFUNC(361.1,10)
- . S X=IBGRP
- . D FILE^DICN K DIC,DO,DD,DLAYGO
- . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment group code could not be added" Q
- . S IBDA(1)=+Y
- ;
- I $G(IBDA(1)) D  ;Add a new entry at the reason code level
- . S DIC="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,",DIC(0)="L",DLAYGO=361.111,DA(2)=IBEOB,DA(1)=IBDA(1)
- . S DIC("P")=$$GETSPEC^IBEFUNC(361.11,1)
- . S X=$P(IB0,U,4)
- . D FILE^DICN K DIC,DO,DD,DLAYGO
- . I Y<0 K IBDA S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Adjustment reason code could not be added" Q
- . S IBDA=+Y
- ;
- I $G(IBDA) D
- . S LEVEL=10,LEVEL("DIE")="^IBM(361.1,"_IBEOB_",10,"_IBDA(1)_",1,"
- . S LEVEL(0)=IBDA,LEVEL(1)=IBDA(1),LEVEL(2)=IBEOB
- . S A="5;.02;1;0;0^6;.03;0;1;1^7;.04;0;1;0"
- . S IBOK=$$STORE^IBCEOB1(A,IB0,IBEOB,.LEVEL)
- . I 'IBOK S ^TMP(IBEGBL,$J,+$O(^TMP(IBEGBL,$J,""),-1)+1)="Bad adjustment reason code ("_$P(IB0,U,4)_") data" Q
-Q20 Q $G(IBOK)
  ;
 35(IB0,IBEGBL,IBEOB) ; Record '35'
@@ -223,2 +163,59 @@
  Q X
  ;
+UPDNM(IBEOB,IB0,IBBULL,IBDR) ; Update name on claim if it comes back changed
+ ; IBEOB = the internal entry # of the entry in file 361.1
+ ; IB0 = the raw data returned from the 835 flat file
+ ; IBBULL = holds result of name change check in piece 1 - if name
+ ;          changed, first '^' piece is 1, 3rd '^' piece is the old
+ ;          insured's name
+ ; IBDR = returned as the updated 'DR' string with the name changed
+ ;       fields to use to update the EOB file (361.1) - pass by reference
+ ;
+ N IBCHGED,IBIFN,IBNEW,IBCOB,DIE,DR,X,Y
+ I $P(IB0,U,7) D
+ . S IBNEW=$P(IB0,U,3)_","_$P(IB0,U,4)_$S($P(IB0,U,5)'="":" "_$P(IB0,U,5),1:""),$P(IBBULL,U)=1
+ . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15)
+ . S IBIFN=+$G(^IBM(361.1,+IBEOB,0))
+ . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB))
+ . ;
+ . I IB'="",$P(IB,U,17)'=IBNEW D
+ .. ; Update the claim data only
+ .. S $P(IBBULL,U,3)=$P(IB,U,17) ; save old value
+ .. S $P(IB,U,17)=IBNEW
+ .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB
+ .. D:DA ^DIE
+ .. S IBCHGED=1
+ . S IBDR=$G(IBDR)_"6.01////"_$P(IB0,U,3)_","_$P(IB0,U,4)_" "_$P(IB0,U,5)_";"
+ ;
+ Q $G(IBCHGED)
+ ;
+UPDID(IBEOB,IB0,IBBULL,IBDR) ; Update id # on claim and policy if it comes back
+ ;   changed
+ ; IBEOB = the internal entry # of the entry in file 361.1
+ ; IB0 = the raw data returned from the 835 flat file
+ ; IBBULL = holds result of id change check in piece 2 - if id changed,
+ ;          second '^' piece = 1,4th '^' piece is the old insured's id
+ ; IBDR = returned as the updated 'DR' string with the id changed fields
+ ;        to use to update the EOB file (361.1) - pass by reference
+ ;
+ N IBCHGED,IBNEW,IBCOB,IB,DIE,DR,DA,X,Y
+ I $P(IB0,U,8) D
+ . S IBNEW=$P(IB0,U,6),$P(IBBULL,U,2)=1
+ . S IBIFN=+$G(^IBM(361.1,+IBEOB,0))
+ . S IBCOB=+$P($G(^IBM(361.1,IBEOB,0)),U,15)
+ . S IB=$G(^DGCR(399,IBIFN,"I"_IBCOB))
+ . ;
+ . I IB'="",$P(IB,U,2)'=IBNEW D
+ .. ; Update the claim
+ .. S $P(IBBULL,U,4)=$P(IB,U,2) ; save old value
+ .. S $P(IB,U,2)=IBNEW
+ .. S DIE="^DGCR(399,",DA=IBIFN,DR="30"_IBCOB_"////"_IB D ^DIE
+ .. ;
+ .. ; Update the policy
+ .. S DA(1)=$P($G(^DGCR(399,IBIFN,0)),U,2),DA=$P($G(^("M")),U,(11+IBCOB)),DR="1////"_IBNEW,DIE="^DPT("_DA(1)_",.312,"
+ .. I DA(1),DA D ^DIE
+ .. S IBCHGED=1
+ . S IBDR=$G(IBDR)_"6.02////"_$P(IB0,U,6)_";"
+ ;
+ Q $G(IBCHGED)
+ ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99
- ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,191,239,232,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -67,18 +67,8 @@
  S IBDSP=Y,IBSORT=""
  I IBDSP="A"!(IBDSP="I") F  D  Q:'IBOK!(IBSORT'="")
- . ;
- . I IBDSP="A" D
- .. S DIR("A")="Display only IDs with a specific ID Qualifier?: "
- .. S DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs."
- .. S DIR("?")="Answer No to display all IDs."
- .. Q
- . ;
- . I IBDSP="I" D
- .. S DIR("A")="Display IDs for a specific Provider?: "
- .. S DIR("?",1)="Answer Yes to select a specific Provider."
- .. S DIR("?")="Answer No to display all Providers."
- .. Q
- . ;
- . S DIR("B")="NO",DIR(0)="YA"
+ . N Z
+ . S Z=$S(IBDSP="I":"",1:" ID TYPE")
+ . S DIR("A")="DO YOU WANT TO DISPLAY IDS FOR A SPECIFIC PROVIDER"_Z_"?: ",DIR("B")="NO",DIR(0)="YA"
+ . S DIR("?",1)="IF YOU ANSWER YES TO THIS QUESTION, YOU MAY SELECT A SPECIFIC PROVIDER"_Z,DIR("?")="  TO DISPLAY, OTHERWISE, ALL PROVIDER"_Z_"S FOUND WILL BE DISPLAYED"
  . W ! D ^DIR K DIR W !
  . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q
@@ -86,7 +76,5 @@
  . ;
  . I IBDSP="A" D  Q
- .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)"
- .. S DIC("A")="Select type of ID Qualifier: "
- .. D ^DIC K DIC
+ .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" D ^DIC K DIC
  .. I Y>0 S IBSORT=+Y Q
  .. I $D(DTOUT)!$D(DUOUT) S IBOK=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP0A.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCEP0A ;ALB/TMP - EDI UTILITIES for insurance assigned provider ID ;01-NOV-00
- ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94
  ;
 NEW(IBINS,IBPRV,IBPTYP,IBDEF) ; Add new insurance co assigned id
@@ -26,5 +25,5 @@
  I '$G(IBPTYP) D  G:IBQ NEWQ
  . S DIR(0)="PAr^355.97:AEMQ",DIR("A")="Select Provider ID Qualifier: "
- . S DIR("?")="Enter a Qualifier to identify the type of ID number you are entering."
+ . S DIR("?")="Enter a Qualifier to indentify the type of ID number you are entering."
  . S DIR("S")="I $$RAINS^IBCEPU(Y)"   ; Rendering/Attending IDs provided by ins
  . S DA=0
@@ -101,10 +100,9 @@
  Q
  ;
-PRVTJMP(VALMBG) ; Navigate to a specific type of ID qualifier (from ins co option)
+PRVTJMP(VALMBG) ; Navigate to a specific provider id type (from ins co option)
  ;
  N DIR,X,Y
  D FULL^VALM1
- S DIR(0)="PAO^355.97:AEMQ",DIR("A")="Select type of ID Qualifier: "
- S DIR("?")="Select a type of ID Qualifier to display the IDs of that type."
+ S DIR(0)="PAO^355.97:AEMQ",DIR("A")="SELECT PROVIDER ID TYPE: ",DIR("?",1)="SELECTING A PROVIDER ID TYPE WILL FORCE THE DISPLAY TO SKIP TO THE DATA FOR ",DIR("?")="  THAT PROVIDER ID TYPE"
  S DIR("S")="I $D(^TMP(""IBPRV_INS_ID"",$J,""ZXPTYP"",+Y))"
  W ! D ^DIR K DIR W !
@@ -113,5 +111,5 @@
  . S Z=$G(^TMP("IBPRV_INS_ID",$J,"ZXPTYP",+Y))
  . I Z S VALMBG=Z Q
- . S DIR(0)="EA",DIR("A",1)="This type of ID Qualifier does not exist in the current display",DIR("A")="Press the Enter key to continue"
+ . S DIR(0)="EA",DIR("A",1)="THIS PROVIDER ID TYPE DOES NOT EXIST IN THE CURRENT DISPLAY",DIR("A")="PRESS THE ENTER KEY TO CONTINUE"
  . W ! D ^DIR K DIR W !
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEP4 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
- ;;2.0;INTEGRATED BILLING;**137,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -10,5 +10,4 @@
 EN1(IBINS) ; -- Entry point from provider number maintenence
  N IBPRV,IBALL,IB95
- S VALMBCK="R"
  D ENX
  Q
@@ -18,6 +17,6 @@
  K IBFASTXT
  D FULL^VALM1
- S DIR(0)="SA^1:Performing Provider Care Units;2:Billing Provider Care Units"
- S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";",1)
+ S DIR(0)="SA^1:Care Units for Performing Provider IDs;2:Care Units for Billing Provider Secondary IDs"
+ S DIR("A")="Enter Type of Care Unit: ",DIR("B")=$P($P(DIR(0),":",2),";")
  W ! D ^DIR K DIR W !
  I Y'>0 Q
@@ -66,5 +65,5 @@
  .. D SET^VALM10(IBLCT,IBQ,IBENT)
  ;
- I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co")) S IBLCT=1
+ I 'IBLCT D SET^VALM10(1,"No CARE UNITs Found"_$S('$G(IBINS):"",1:" for Insurance Co"))
  S VALMCNT=IBLCT,VALMBG=1
  Q
@@ -78,4 +77,5 @@
  ;
 EXIT ; -- exit
+ K IBFASTXT
  D CLEAN^VALM10
  K ^TMP("IBPRV_CU",$J),IBINS,IBALL
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
- ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,232,280,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -23,6 +23,6 @@
  ; IB = 0 or null if called from list manager, 1 if not
  N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT
- I '$G(IB) D FULL^VALM1 S Y=$$SEL()
- I $G(IB) S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
+ I '$G(IB) D FULL^VALM1
+ S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
  I Y'>0 G CHGQ
  S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1))
@@ -30,5 +30,13 @@
  W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR
  I $D(DTOUT)!$D(DUOUT) G CHGQ
- I X="@" S DIR(0)="EA",DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE" D ^DIR K DIR G CHGQ
+ ;
+ ; Care unit name was deleted
+ I X="@" D  G CHGQ
+ . S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
+ . I Y'=1 S IB95("IBCU")="" Q  ; Changed their mind - don't delete
+ . S Z=0 F  S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z  S DIK="^IBA(355.96,",DA=Z D ^DIK
+ . S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
+ . W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
+ ;
  I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change
  S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE
@@ -152,24 +160,2 @@
  Q Y
  ;
-DELETE(IB) ; delete a care unit name
- ; IB = 0 or null if called from list manager, 1 if not
- N DIR,X,Y
- I '$G(IB) D FULL^VALM1 S Y=$$SEL() I Y'>0 G DELETEQ
- S:'$G(IB) IB95("IBCU")=+Y
- S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
- I Y'=1 S IB95("IBCU")="" Q  ; Changed their mind - don't delete
- S Z=0 F  S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z  S DIK="^IBA(355.96,",DA=Z D ^DIK
- S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
- W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
-DELETEQ ;
- S:'$G(IB) VALMBCK="R"
- Q
- ;
-SEL() ; Select entry from list
- ; returns ien in file 355.95 for selected entry
- N VALMY,SEL
- D EN^VALM2($G(XQORNOD(0)),"S")
- S SEL=+$O(VALMY(""))
- I SEL'>0 Q 0
- Q +$G(^TMP("IBPRV_CU",$J,"ZIDX",SEL))
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP5.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
- ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -140,4 +140,5 @@
  ;
 EXIT ; -- exit code
+ K IBFASTXT
  D COPYPROV^IBCEP5A(IBINS)
  K IBPRV
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP6.m	(revision 636)
@@ -1,145 +1,90 @@
 IBCEP6 ;ALB/TMP - PROVIDER ID MAINT menu and INS CO EDIT hook ;11-02-00
- ;;2.0;INTEGRATED BILLING;**137,232,320,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,232,320**;21-MAR-94
  ;
-EN ; -- main entry point
- N IBRESP
+EN ; -- main entry point for IBCE PRV INS PARAMS
  D FULL^VALM1
- F  Q:'$$MENU(.IBRESP)  D @IBRESP
-ENQ ;
+ D EN^VALM("IBCE PRVMAINT")
+ENQ Q
+ ;
+HDR ; -- header code
+ K VALMHDR
+ Q
+ ;
+INIT ; Initialization
+ N IBLCT,IBCT,Z,Z0
+ S (IBLCT,IBCT)=0,XQORM("B")="Select"
+ K ^TMP("IBCE_PRVMAINT_MENU",$J)
+ F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",17)_"-- PROVIDER ID EDITS --" D SET1(.IBLCT,Z0,1),CNTRL^VALM10(IBLCT,18,23,IORVON,IORVOFF)
+ S Z0=$J("",10)_"1 > PROVIDER SPECIFIC IDS" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",14)_"o PROVIDER'S OWN IDS" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",14)_"o PROVIDER IDS FURNISHED BY INSURANCE CO" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",10)_"2 > INSURANCE CO IDS" D SET1(.IBLCT,Z0,2)
+ ;S Z0=$J("",10)_"3 > FACILITY IDS" D SET1(.IBLCT,Z0,3)  ;WCJ removed
+ S Z0=$J("",10)_"4 > CARE UNIT MAINTENANCE" D SET1(.IBLCT,Z0,4)
+ S Z0=$J("",14)_"o Care Units for Performing Provider IDs" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",14)_"o Care Units for Billing Provider Secondary IDs" D SET1(.IBLCT,Z0,1)
+ S Z0=$J("",10)_"5 > INS CO BATCH ID ENTRY" D SET1(.IBLCT,Z0,5)
+ F Z=1:1:2 S Z0=$J("",10) D SET1(.IBLCT,Z0,6)
+ S Z0=$J("",14)_"-- NON/OTHER VA ENTITY EDITS --" D SET1(.IBLCT,Z0,6),CNTRL^VALM10(IBLCT,15,31,IORVON,IORVOFF)
+ S Z0=$J("",10)_"6 > NON/OTHER VA PROVIDER ID INFORMATION" D SET1(.IBLCT,Z0,6)
+ K VALMBG,VALMCNT
+ S VALMBG=1,VALMCNT=IBLCT
+ Q
+ ;
+SET1(IBLCT,Z0,IBCT) ;
+ S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,Z0,$G(IBCT))
+ Q
+ ;
+EXPND ;
+ Q
+ ;
+HELP ;
+ Q
+ ;
+EXIT ;
+ K ^TMP("IBCE_PRVMAINT_MENU",$J)
+ D CLEAN^VALM10
+ Q
+ ;
+SEL ;
+ N Z,Z1,DIR
+ D FULL^VALM1
+ D EN^VALM2($G(XQORNOD(0)),"OS")
+ S Z=+$O(VALMY(0))
+ I Z,Z<6,'$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A",1)="YOU ARE NOT AUTHORIZED TO EDIT PROVIDER IDS",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W ! G SELQ
+ I Z=3 D  G SELQ
+ . S DIR(0)="EA",DIR("A",1)="This Action is no longer available",DIR("A")="Press ENTER to continue"
+ . D ^DIR K DIR
+ I Z S Z1=$P($T(ACT+Z),U,2,3) I Z1'="" D @Z1
+SELQ K VALMBCK,XQORM("B")
+ S VALMBCK="R",XQORM("B")="Quit"
  Q
  ;
 EN1 ; Provider maintenance from the billing screen 8
  N DIR,X,Y,IBEDIT
+ ;S IBEDIT=1
  W !
+ ;S DIR(0)="YA",DIR("B")="NO",DIR("A",1)="WANT TO ATTEMPT TO RESET ALL PROVIDER IDS TO THE CALCULATED",DIR("A")="DEFAULTS FOR THIS BILL?: " D ^DIR K DIR
+ ;Q:$D(DTOUT)!$D(DUOUT)
+ ;I Y=1 S IBEDIT=0 D RECALCA^IBCEP2A(IBIFN) W !
+ ;
  I '$D(^XUSEC("IB PROVIDER EDIT",DUZ)) S DIR(0)="EA",DIR("A")="Press ENTER to continue: ",DIR("A",1)="YOU LACK THE SECURITY KEY FOR THIS ACTION" D ^DIR K DIR Q
+ ;I 'IBEDIT D
+ ;. S DIR(0)="YA",DIR("A")="WANT TO CONTINUE WITH GENERAL PROVIDER ID MAINTENANCE?: ",DIR("B")="NO" D ^DIR K DIR
+ ;. I $D(DTOUT)!$D(DUOUT)!'Y Q
+ ;. S IBEDIT=1
  D EN
  Q
  ;
-PO ; provider's own IDs
- N IBPRV,IBINS
- N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
- K IBFASTXT
- S IBIF=""
- S IBPRMPT="PROVIDER"
- D FULL^VALM1
- S IBSLEV=1
- D EN^VALM("IBCE PRVPRV MAINT")
-POX ;
- Q
+ACT ; Actions available
+ ;;PROVIDER LEVEL ID EDIT^EN^IBCEP5
+ ;;INS CO LEVEL ID EDIT^EN^IBCEP0
+ ;;
+ ;;CARE UNIT EDIT^EN^IBCEP4
+ ;;BATCH ID ENTRY BY INS CO^EN^IBCEP9
+ ;;NON-VA PROVIDER EDIT^EN^IBCEP8
  ;
-PI ; provider's IDs provided by an insurance company
- N IBPRV,IBINS
- N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
- K IBFASTXT
- S IBIF=""
- S IBPRMPT="PROVIDER"
- D FULL^VALM1
- S IBSLEV=2
- D EN^VALM("IBCE PRVPRV MAINT")
-PIX ;
- Q
  ;
-BI ; Insurance company batch ID entry
- D EN^IBCEP9
-BIX ;
- Q
  ;
-II ; Insurance company IDs
- D EN^IBCEP0
-IIX ;
- Q
- ;
-CP ; Care Unit maintenance - performing providers
- N IBINS,IBALL,IB95
- N IBSLEV,DIR,Y
- K IBFASTXT
- D FULL^VALM1
- S IBSLEV=1
- D EN^VALM("IBCE PRVCARE UNIT MAINT")
-CPX ;
- Q
- ;
-CB ; Care Unit maintenance - billing provider
- N IBINS,IBALL,IB95
- N IBSLEV,DIR,Y
- K IBFASTXT
- D FULL^VALM1
- S IBSLEV=2
- D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
-CBX ;
- Q
- ;
-NP ; non-VA individual provider information
- N IBNVPMIF
- S IBNVPMIF="I"
- D EN^IBCEP8
-NPX ;
- Q
- ;
-NF ; non-VA facility provider information
- N IBNVPMIF
- S IBNVPMIF="F"
- D EN^IBCEP8
-NFX ;
- Q
- ;
-MENU(IBSEL) ; display main provider ID maintenance menu and receive response from user
- ; function value returns 0 if user exits from menu or "^" out
- ; function value returns 1 otherwise
- ; IBSEL is the internal value of the user's selection if any (pass by reference)
- N IBQ,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,C,Z
- N IORESET,IORVON,IORVOFF,IOUON,IOUOFF,IOINHI,IOINLOW,IOINORM
- S IBQ=1,IBSEL=""
- S X="IORESET;IORVON;IORVOFF;IOUON;IOUOFF;IOINHI;IOINLOW;IOINORM"
- D ENDR^%ZISS
- ;
- S $P(DIR(0),U,1)="SOA"
- S $P(Z,";",1)="PO:Provider Own IDs"
- S $P(Z,";",2)="PI:Provider Insurance IDs"
- S $P(Z,";",3)="BI:Batch ID Entry"
- S $P(Z,";",4)="II:Insurance Co IDs"
- S $P(Z,";",5)="CP:Care Units for Providers"
- S $P(Z,";",6)="CB:Care Units for Billing Provider"
- S $P(Z,";",7)="NP:Non-VA Provider"
- S $P(Z,";",8)="NF:Non-VA Facility"
- ;
- S $P(DIR(0),U,2)=Z
- ;
- S DIR("L",1)="                "_IOINHI_"Provider IDs"_IOINORM
- S DIR("L",2)="          "_$P($P(Z,";",1),":",1)_"  "_$P($P(Z,";",1),":",2)
- S DIR("L",3)="          "_$P($P(Z,";",2),":",1)_"  "_$P($P(Z,";",2),":",2)
- S DIR("L",4)=""
- S DIR("L",5)="                "_IOINHI_"Insurance IDs"_IOINORM
- S DIR("L",6)="          "_$P($P(Z,";",3),":",1)_"  "_$P($P(Z,";",3),":",2)
- S DIR("L",7)="          "_$P($P(Z,";",4),":",1)_"  "_$P($P(Z,";",4),":",2)
- S DIR("L",8)=""
- S DIR("L",9)="                "_IOINHI_"Care Units"_IOINORM
- S DIR("L",10)="          "_$P($P(Z,";",5),":",1)_"  "_$P($P(Z,";",5),":",2)
- S DIR("L",11)="          "_$P($P(Z,";",6),":",1)_"  "_$P($P(Z,";",6),":",2)
- S DIR("L",12)=""
- S DIR("L",13)="                "_IOINHI_"Non-VA Items"_IOINORM
- S DIR("L",14)="          "_$P($P(Z,";",7),":",1)_"  "_$P($P(Z,";",7),":",2)
- S DIR("L")="          "_$P($P(Z,";",8),":",1)_"  "_$P($P(Z,";",8),":",2)
- ;
- S DIR("?")="^D MENH^IBCEP6"
- S DIR("A")="    Select Provider ID Maintenance Option: "
- ;
- ; paint the screen and display menu first time in
- D MENH
- W !
- S C=0 F  S C=$O(DIR("L",C)) Q:'C  W !,DIR("L",C)
- W !,DIR("L"),!
- D ^DIR K DIR W !
- I $D(DIRUT) S IBQ=0 G MENUX
- S IBSEL=Y
- I IBSEL="" S IBQ=0
-MENUX ;
- Q IBQ
- ;
-MENH ; menu help
- W @IOF,!?4,"Provider ID Maintenance Main Menu"
- W !!?4,"Enter a code from the list."
-MENHX ;
- Q
- ;
+ ;;SITE LEVEL ID EDIT^EN^IBCEP7
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP8.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
- ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374**;21-MAR-94;Build 16
  ;
 EN ; -- main entry point
@@ -17,13 +16,7 @@
  N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
  K ^TMP("IBCE_PRVNVA_MAINT",$J)
- ;
- ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
- I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
- ;
  S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
  I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
  S IBIF=Y
- ;
-INIT1 ;
  ;
  I IBIF="F" D
@@ -33,5 +26,5 @@
  . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
  ;
- S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
+ S DIC="^IBA(355.93,",DIC("DR")=".02////"_$S(IBIF'="F":2,1:1)
  S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
  S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
@@ -140,29 +133,18 @@
  Q
  ;
-EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
- ; This entry point is called by 4 action protocols.
- ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
- ; IBSLEV = 1 for facility/provider own ID's
- ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
- ;
- Q:'$G(IBNPRV)
- Q:'$G(IBSLEV)
- N IBPRV,IBIF
- D FULL^VALM1    ; set full scrolling region
- D CLEAR^VALM1   ; clear screen
+EDITID(IBNPRV) ; Link from this list template to maintain provider-specific ids
+ ; IBNPRV = ien of entry in file 355.93
+ N IBPRV
+ D FULL^VALM1
+ D CLEAR^VALM1
  S IBPRV=IBNPRV
- ;
- K IBFASTXT
- S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")    ; 1=facility/group      2=individual
- D EN^VALM("IBCE PRVPRV MAINT")
- ;
+ D EN1^IBCEP5
  K VALMQUIT
- S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
+ S VALMBCK="R"
  Q
  ;
 NVAFAC ; Enter/edit Non-VA facility information
- ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
  N X,Y,DA,DIC,IBNPRV,DLAYGO
- S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
+ S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02////1"
  S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
  D ^DIC K DIC,DLAYGO
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP82.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCEP82 ;ALB/CLT, Special cross references and data entry for fields in file 355.93 ; 14 Apr 2006  9:41 AM
- ;;2.0;INTEGRATED BILLING;**343,374,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**343,374**;21-MAR-94;Build 16
  ;
  ; Call at tags only
@@ -25,29 +24,12 @@
  I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN1
  I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
- I '$$PROC(Y,IBOLDNPI,IBIEN) G EN1
- G XIT
- ;
-EN2(DA,INDENT) ; entry point from input templates IB SCREEN82 and IB SCREEN8H
- N DTOUT,DUOUT,DIR,DIE,DIC,DR,X,Y
- N IBIEN,IBNPI,IBCHECK,IBOLDNPI,IBRBNPI,IBRB,SPACES
- S IBIEN=DA,IBOLDNPI="",SPACES="          "
-EN21 ;
- K DIR
- S DIR(0)="FO^10:10",DIR("A")=$E(SPACES,1,INDENT)_"NPI",DIR("?")=$E(SPACES,1,INDENT)_"Enter a 10 digit National Provider Identifier"
- I $G(DA) S:$P($G(^IBA(355.93,DA,0)),U,14)'="" (DIR("B"),IBOLDNPI)=$P($G(^IBA(355.93,DA,0)),U,14)
- D ^DIR S IBCHECK=0
- I X="@" G:IBOLDNPI'="" DEL W *7,"??" G EN21
- I $G(DUOUT)!$G(DTOUT)!(X="")!(Y=IBOLDNPI) G XIT
- I '$$PROC(Y,IBOLDNPI,IBIEN) G EN21
- G XIT
- ;
-PROC(IBNPI,IBOLDNPI,IBIEN) ; process new NPI
- I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,$E($G(SPACES),1,+$G(INDENT))_"Not a valid NPI.  Please try again.",! Q 0
- I $$NPIUSED^IBCEP81(IBNPI) Q 0
+ S IBNPI=Y
+ I '$$CHKDGT^XUSNPI(IBNPI) W !,*7,"Not a valid NPI.  Please try again.",! G EN1
+ I $$NPIUSED^IBCEP81(IBNPI) G EN1
  S IBCHECK=1
  I IBOLDNPI="" D ACTI
  I IBOLDNPI'="" D:IBNPI'=IBOLDNPI INACT
  S $P(^IBA(355.93,IBIEN,0),U,14)=IBNPI,^IBA(355.93,"NPI",IBNPI,IBIEN)="",^IBA(355.93,"NPIHISTORY",IBNPI,IBIEN)=""
- Q 1
+ G XIT
  ;
 ACTI ;CREATE AN ACTIVATED ENTRY IN MULTIPLE NPISTATUS FIELD
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEPA.m	(revision 636)
@@ -1,6 +1,4 @@
 IBCEPA ;ALB/WCJ - Provider ID functions - Care Units ;21-OCT-2005
- ;;2.0;INTEGRATED BILLING;**320,348,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+ ;;2.0;INTEGRATED BILLING;**320,348**;21-MAR-94;Build 5
 EN ; -- main entry point for IBCE 2ND PRVID CARE UNIT MAINT
  D EN^VALM("IBCE 2ND PRVID CARE UNIT MAINT")
@@ -27,5 +25,5 @@
  D CLEAN^VALM10
  K ^TMP("IBPRV_CU",$J)
- N TAR,MSG,I,D0,IBCT,Z,DIV,SCREEN
+ N TAR,MSG,I,D0,IBLCT,Z,DIV,SCREEN
  ;
  S VALMBG=1
@@ -51,12 +49,9 @@
  ... S IN=^TMP("IBPRV_CU",$J,"SORT",DIV,D0)
  ... S Z=$J("",2)
- ... S Z=Z_$E(IN_"    ",1,4)_$E(TAR("DILIST","ID",IN,.01),1,36)
+ ... S Z=Z_$E(TAR("DILIST","ID",IN,.01),1,36)
  ... S Z=Z_$J("",40-$L(Z))
  ... S Z=Z_$E(TAR("DILIST","ID",IN,.02),1,38)
  ... S IBCT=IBCT+1
  ... D SET^VALM10(IBCT,Z)
- ;
- ; correct the VALMCNT variable - number of lines in the list (not entries)
- S VALMCNT=+$O(@VALMAR@(""),-1)
  Q
  ;
@@ -67,5 +62,4 @@
 EXIT ; -- exit code
  D CLEAN^VALM10
- K ^TMP("IBPRV_CU",$J)
  Q
  ;
@@ -76,5 +70,5 @@
  ; Assumes IBINS is defined as ins co ien (file 36)
  ; IB = 0 or null if called from list manager, 1 if not
- N DIC,DIR,X,Y,Z,D,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
+ N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK,IBDIV,MAIN,IBDIVNM
  ;
  D FULL^VALM1
@@ -85,6 +79,5 @@
  S MAIN=$$EXTERNAL^DILFD(355.92,.05,"",MAIN)
  S DIC=40.8,DIC("A")="Enter the Division for this Care Unit: ",DIC("B")=MAIN,DIC(0)="AEMQ"
- S D="B^C"
- D MIX^DIC1
+ D ^DIC
  I Y'>0 G NEWQ
  S IBDIV=+Y
@@ -153,8 +146,8 @@
 CHANGE ; Edit care unit
  ; Assumes IBINS is defined as ins co ien (file 36)
- ;
+ ; 
  D FULL^VALM1
  ;
- N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION,I
+ N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
  ;
  S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
@@ -173,10 +166,14 @@
  S DIC(0)="AEMQ"
  S DIC("S")="I $D(DIVISION($P(^(0),U)))"
- S D="B^C"
- D MIX^DIC1
+ D ^DIC
  I Y'>0 G CHANGEQ
  S IBDIV=+Y
- S DA=$$SEL($P(Y,U,2)) I 'DA G CHANGEQ
- S DIE=355.95
+ ;
+ S DIC("A")="Enter the Care Unit name: "
+ S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
+ D ^DIC
+ I Y<1 G CHANGEQ
+ ;
+ S DA=+Y,DIE=355.95
  S DR=".01Care Unit;.04Division;.02Description"
  D ^DIE
@@ -191,5 +188,5 @@
  ; 
  D FULL^VALM1
- N X,Y,Z,D,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
+ N X,Y,Z,DA,DD,DIC,DIK,DIR,IBDIV,CAREUNIT,SCREEN,TAR,DIVISION
  ;
  S SCREEN="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)]"""""
@@ -208,9 +205,14 @@
  S DIC(0)="AEMQ"
  S DIC("S")="I $D(DIVISION($P(^(0),U)))"
- S D="B^C"
- D MIX^DIC1
+ D ^DIC
  I Y'>0 G DELQ
  S IBDIV=+Y
- S CAREUNIT=$$SEL($P(Y,U,2)) I 'CAREUNIT G DELQ
+ ;
+ K DIC
+ S DIC("A")="Enter the Care Unit name: "
+ S DIC=355.95,DIC("S")="I $P(^(0),U,3)=+$G(IBINS),$P(^(0),U,4)=+$G(IBDIV)",DIC(0)="AEMQ"
+ D ^DIC
+ I Y<1 G DELQ
+ S CAREUNIT=+Y
  ;
  I $D(^IBA(355.92,"AC",+Y)) D  G DELQ
@@ -244,17 +246,2 @@
  Q
  ;
-SEL(DIV) ; select care unit for a given division
- ; DIV - name of division
- ; returns ien of selected care unit, or 0 if nothing is selected
- N DIR,I,IEN,MIN,MAX,X,Y
- I $G(DIV)="" Q 0
- S IEN=0
- S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,"")),MIN=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
- S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,""),-1),MAX=$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))
- I MIN=MAX S IEN=I
- I MIN'=MAX D
- .S DIR("A")="Select CARE UNITS",DIR(0)="N^"_MIN_":"_MAX_":0" D ^DIR
- .Q:$D(DTOUT)!$D(DUOUT)
- .S I="" F  S I=$O(^TMP("IBPRV_CU",$J,"SORT",DIV,I)) Q:I=""!(IEN>0)  S:$G(^TMP("IBPRV_CU",$J,"SORT",DIV,I))=Y IEN=I
- .Q
- Q IEN
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCERP3.m	(revision 636)
@@ -1,134 +1,58 @@
 IBCERP3 ;ALB/TMP - EDI BATCHES WAITING MORE THAN 1 DAY REPORT ;30-SEP-96
- ;;2.0;INTEGRATED BILLING;**137,296,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+ ;;2.0;INTEGRATED BILLING;**137,296**;21-MAR-94
  Q
  ;
-PENDING ; Report of batches not sent after the day the bills in it were extracted - report entry point
- ;
- NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,IBCLM
- I '$O(^IBA(364.1,"ASTAT","P",0)) W !!,"There are no batches that are Pending Austin Receipt.",! S DIR(0)="E" D ^DIR K DIR G EX
- ;
- ; Ask user if they want to include claim level detail
- S DIR(0)="Y",DIR("A")="Include Claims in each Batch",DIR("B")="Yes"
- W ! D ^DIR K DIR
- I $D(DIRUT) G EX
- S IBCLM=+Y
- ;
- D DEVICE
-EX ;
- Q
- ;
-DEVICE ; selection of device on which to print report
- NEW ZTRTN,ZTDESC,ZTSAVE,POP
- W !!,"This report is 80 characters wide."
- S ZTRTN="COMPILE^IBCERP3"
- S ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY"
- S ZTSAVE("IBCLM")=""
- D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"QM")
-DEVICEX ;
- Q
- ;
-COMPILE ; Queued job entrypoint
- N IBBA,IB0,IB1,IEN,IBZ,IBIFN,IB399,CLM,BALDUE,IBSTAT,ARSTAT,IB
+PENDING ;Report of batches not sent after the day the bills in it were extracted
+ W !
+ S %ZIS="QM" D ^%ZIS Q:POP
+ I $D(IO("Q")) K IO("Q") S ZTRTN="EN^IBCERP3",ZTDESC="REPORT OF BILL BATCHES WAITING AUSTIN RECEIPT AFTER 1 DAY" D ^%ZTLOAD K ZTSK D HOME^%ZIS Q
+ U IO
+EN ; Queued job entrypoint
+ N IBPAGE,IBHDRDT,IBLINE,IBSTOP,IBBA,IBBAT,IBCT,IBTYP,IBTYPN,IBV,DIR,Y,IB0,IB1
  ;
  K ^TMP($J,"IBSORT")
- S IBBA=0
- F  S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA  D
- . I $$BCHCHK^IBCEBUL(IBBA) Q    ; Batch check function
- . S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1))
- . S:$P(IB0,U,7)="" $P(IB0,U,7)="~"
- . S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4)
- . ;
- . I 'IBCLM Q   ; include claim data flag
- . ;
- . ; gather the EDI claim data for this batch
- . S IEN=0 F  S IEN=$O(^IBA(364,"C",IBBA,IEN)) Q:'IEN  D
- .. S IBZ=$G(^IBA(364,IEN,0)),IBIFN=+IBZ,IB399=$G(^DGCR(399,IBIFN,0))
- .. S CLM=$P(IB399,U,1) S:CLM="" CLM="~"
- .. S BALDUE=$G(^DGCR(399,IBIFN,"U1")),BALDUE=$P(BALDUE,U,1)-$P(BALDUE,U,2)
- .. S IBSTAT=$$EXTERNAL^DILFD(399,.13,,$P(IB399,U,13))
- .. S ARSTAT=$$EXTERNAL^DILFD(430,8,,+$P($$BILL^RCJIBFN2(IBIFN),U,2))
- .. S IB=$P(IBZ,U,8)_U_BALDUE_U_$P(IBZ,U,3)_U_IBSTAT_U_ARSTAT
- .. S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U,1),IBBA,CLM,IEN)=IB
- .. Q
- . Q
+ S (IBPAGE,IBBA)=0
  ;
- D PRINT                         ; print report
- D ^%ZISC                        ; close the device
- K ^TMP($J,"IBSORT")             ; clean up scratch global
- I $D(ZTQUEUED) S ZTREQ="@"      ; purge the task record
+ ; esg - 5/12/05 - IB*2*296 - Additional check to make sure there are 
+ ;       bills in the batch in file 364 before including it.  Similar to
+ ;       existing functionality in routine ^IBCEBUL.
  ;
-COMPX ;
- Q
+ F  S IBBA=$O(^IBA(364.1,"ASTAT","P",IBBA)) Q:'IBBA  S IB0=$G(^IBA(364.1,IBBA,0)),IB1=$G(^(1)) I DT-($P(IB1,U,6)\1)'<1,$P(IB0,U,7)'="",$O(^IBA(364,"C",IBBA,0)) S ^TMP($J,"IBSORT",$P(IB0,U,7),$P(IB0,U),IBBA)=$P(IB1,U,6)_U_$P(IB0,U,4)
  ;
-PRINT ; print the report to the specified device
- ;
- NEW CRT,IBPAGE,IBSTOP,IBCT,IBTYP,IBBAT,IBBA,IBV,CLM,IEN,DIR,X,Y,Z
- I IOST["C-" S CRT=1
- E  S CRT=0
- ;
- S IBPAGE=0
- I '$D(^TMP($J,"IBSORT")) D HDR1 W !,?3,"No batches found Pending Austin Receipt for >1 day."
+ W:$E(IOST,1,2)["C-" @IOF ;Only initial form feed for print to screen
+ I '$D(^TMP($J,"IBSORT")) D HDR1("") W !,?3,"No data found for this report"
  S (IBSTOP,IBCT)=0
  ;
  S IBTYP=""
- F  S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP=""  D  Q:IBSTOP
- . D HDR1
+ F  S IBTYP=$O(^TMP($J,"IBSORT",IBTYP)) Q:IBTYP=""  D  G:IBSTOP STOP
+ . S IBTYPN=$$EXPAND^IBTRE(364.1,.07,IBTYP)
+ . D HDR1(IBTYPN)
  . S IBBAT=""
- . F  S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP)  S IBBA=0 F  S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA!IBSTOP  S IBV=$G(^(IBBA)) D  Q:IBSTOP
- .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
- .. W !,?2,IBBAT,?16,$$FMTE^XLFDT($P(IBV,U,1),"5Z"),?42,$P(IBV,U,2)
- .. S IBCT=IBCT+1
- .. I 'IBCLM Q    ; no claim level detail
- .. I $O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,""))="" Q   ; no claim data
- .. ;
- .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
- .. W !!?5,"Claim",?14,"Seq",?22,"Bal Due",?32,"EDI Stat",?43,"IB Status",?57,"AR Status"
- .. S CLM="" F  S CLM=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM)) Q:CLM=""!IBSTOP  S IEN=0 F  S IEN=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN)) Q:'IEN!IBSTOP  D  Q:IBSTOP
- ... S IBV=$G(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA,CLM,IEN))
- ... D:$Y>(IOSL-4) HDR1 Q:IBSTOP
- ... W !,?5,CLM,?15,$P(IBV,U,1),?19,$J($FN($P(IBV,U,2),"",2),10),?35,$P(IBV,U,3),?43,$E($P(IBV,U,4),1,11),?57,$E($P(IBV,U,5),1,16)
- ... Q
- .. ;
- .. Q:IBSTOP
- .. D:$Y>(IOSL-4) HDR1 Q:IBSTOP
- .. W !
- .. Q
- . Q
+ . F  S IBBAT=$O(^TMP($J,"IBSORT",IBTYP,IBBAT)) Q:'IBBAT!(IBSTOP)  S IBBA=0 F  S IBBA=$O(^TMP($J,"IBSORT",IBTYP,IBBAT,IBBA)) Q:'IBBA  S IBV=$G(^(IBBA)) D  Q:IBSTOP
+ .. D:IBLINE>(IOSL-5) HDR1(IBTYPN) Q:IBSTOP
+ .. W !,?6,IBBAT,?20,$$FMTE^XLFDT($P(IBV,U),1),?46,$P(IBV,U,2)
+ .. S IBCT=IBCT+1,IBLINE=IBLINE+1
  ;
- I IBSTOP G PRINTX
- D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX
- W !!,"Total Number of Batches: ",IBCT
- D:$Y>(IOSL-4) HDR1 G:IBSTOP PRINTX
- W !!?5,"*** End of Report ***"
- I CRT,'$D(ZTQUEUED) S DIR(0)="E" D ^DIR K DIR
-PRINTX ;
+ W !!,"TOTAL # OF BATCHES: ",IBCT
+ ;
+ I $E(IOST,1,2)["C-"  K DIR S DIR(0)="E" D ^DIR K DIR
+STOP I '$D(ZTQUEUED) D ^%ZISC
+ I $D(ZTQUEUED) S ZTREQ="@"
+ K ^TMP($J,"IBSORT")
  Q
  ;
-HDR1 ; Report header
- ;
- ; if screen output and page# already exists, do a page break
- I IBPAGE,CRT D  I IBSTOP G HDR1X
- . S DIR(0)="E" D ^DIR K DIR
- . I 'Y S IBSTOP=1
- . Q
- ;
- ; if screen output OR page# already exists, do a form feed
- I IBPAGE!CRT W @IOF
- ;
+HDR1(IB) ; Report header
+ ; IB = the text for the type of batch
+ N Z,DIR,Y
+ I 'IBPAGE S IBHDRDT=$$HTE^XLFDT($H,2)
+ I IBPAGE D  Q:IBSTOP
+ . I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" D ^DIR K DIR S IBSTOP=('Y) Q:IBSTOP
+ . W @IOF
  S IBPAGE=IBPAGE+1
- ;
- W !,"EDI Batches Pending Austin Receipt After 1 Day",?70,"Page: ",IBPAGE
- W !,"Run Date: ",$$FMTE^XLFDT($$NOW^XLFDT,"5Z")
- W !!?2,"Batch #",?16,"Transmission Date",?42,"Mail Message #"
- S Z="",$P(Z,"-",79)="" W !?1,Z
- ;
- ; check for a TaskManager stop request
- I $D(ZTQUEUED),$$S^%ZTLOAD() D  G HDR1X
- . S (ZTSTOP,IBSTOP)=1
- . W !!!?5,"*** Report Halted by TaskManager Request ***"
- . Q
-HDR1X ;
+ W !,?14,"REPORT OF BATCHES STILL WAITING AUSTIN RECEIPT AFTER 1 DAY",?70,"PAGE: ",IBPAGE,!,?((68-$L(IB))\2),"BATCH TYPE: "_IB
+ W !,?26,"RUN DATE: ",IBHDRDT,!
+ W !,?6,"BATCH #",?20,"WAITING SINCE",?46,"MAIL MESSAGE #",!
+ S Z="",$P(Z,"-",76)="" W ?2,Z,!
+ S IBLINE=6
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEST.m	(revision 636)
@@ -1,5 +1,4 @@
 IBCEST ;ALB/TMP - 837 EDI STATUS MESSAGE PROCESSING ;17-APR-96
- ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320,368**;21-MAR-94;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**137,189,197,135,283,320**;21-MAR-94
  ; IA 4042 for call to AUDITX^PRCAUDT
  Q
@@ -63,5 +62,5 @@
  ;       1 = single bill 0 = batch
  ; 
- N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,Z2,Z3,IBT,IBDUP,IBFLDS,IBY,IBAUTO,IBLN
+ N DA,DIK,DIE,DIC,X,Y,DR,DO,DD,DLAYGO,Z,Z0,Z1,IBT,IBDUP,IBFLDS,IBY,IBAUTO
  ;
  S X=IBBILL,IBDUP=0
@@ -113,20 +112,8 @@
  . D BLDMSG(IB1,IBTDA,.IBT,.IBAUTO)
  . ;
- . ; IB*2*368 - ymg - 2Q,RE,RP messages will be filed as informational
- . ; Z0 is the flag for 2Q code
- . ; Z1 is the flag for RE code
- . ; Z2 is the flag for RP code
- . ; Z3 is the flag for autofiling the message
- . I $P($G(^IBM(361,+IBY,0)),U,3)="R" D
- .. S Z="",(Z0,Z1,Z2,Z3)=0 F  S Z=$O(IBT(Z)) Q:Z=""!(Z3=1)  D
- ... S IBLN=$$UP^XLFSTR($G(IBT(Z)))
- ... I (Z0!Z1!Z2)=0 D
- .... S:IBLN?.E1"CODE:".P1"2Q".E Z0=1
- .... S:IBLN?.E1"CODE:".P1"RE".E Z1=1
- .... S:IBLN?.E1"CODE:".P1"RP".E Z2=1
- ... I Z0=1 S:IBLN?.P1"CLAIM".P1"REJECTED".P1"BY".P1"CLEARINGHOUSE".E Z3=1
- ... I Z1=1 S:IBLN?.P1"ELECTRONIC".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
- ... I Z2=1 S:IBLN?.P1"PAPER".P1"CLAIM".P1"REJECTED".P1"BY".P1"EMDEON".E Z3=1
- .. I Z3=1 S IBAUTO=1,DIE=361,DA=+IBY,DR=".03////I" D ^DIE
+ . ; IB*2*320 - esg - 2Q messages will be filed as informational
+ . I $P($G(^IBM(361,+IBY,0)),U,3)="R",$G(IBT(1))["2Q  CLAIM REJECTED BY CLEARINGHOUSE" D
+ .. S IBAUTO=1
+ .. S DIE=361,DA=+IBY,DR=".03////I" D ^DIE
  .. Q
  . ;
@@ -134,8 +121,6 @@
  . I $G(IBAUTO),$P($G(^IBM(361,+IBY,0)),U,3)="I" D
  .. S DIE="^IBM(361,",DR=".09////2;.14////1;.1////F",DA=+IBY D ^DIE
- .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11) S Z="",Z0=0 F  S Z=$O(IBT(Z)) Q:Z=""!(Z0=1)  D
- ... S Z0=$$PRINTUPD^IBCEU0($$UP^XLFSTR($G(IBT(Z))),$P($G(^IBM(361,+IBY,0)),U,11))
- . ;
- . D MSGLNSZ(.IBT) ; Convert Message Lines in IBT to be no longer than 70 chars
+ .. I IB1,$P($G(^IBM(361,+IBY,0)),U,11),$$PRINTUPD^IBCEU0($G(IBT(1)),$P($G(^IBM(361,+IBY,0)),U,11))
+ . ;
  . D WP^DIE(361,+IBY_",",1,"A","IBT")    ; file message text
  . ;
@@ -158,4 +143,7 @@
  ; Don't move the raw data over, just move the text of the message
  F  S IBZ=$O(^IBA(364.2,IBTDA,2,IBZ)) Q:'IBZ  S IBZ1=$G(^(IBZ,0)) S IBDATA=($E(IBZ1,1,2)="##") Q:IBDATA  S IBZ0=IBZ0+1,IBT(IBZ0)=IBZ1 I 'IBCK S Z=$$CKREVU^IBCEM4(IBZ1,,,.IBCK),IBAUTO=$S(IBCK:0,Z:1,1:IBAUTO)
+ ;
+ ; Convert Message Lines in IBT to be no longer than 70 chars
+ D MSGLNSZ(.IBT)
  Q
  ;
@@ -206,20 +194,24 @@
  ; which is an array of Converted Message Lines (with lines no more than 70 chars each)
  ;
- N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP,LDNGSPN
- S LN="",CNT=0 F  S LN=$O(MSG(LN)) Q:LN=""  D  ;
+ N LN,XARY,XARYLN,CNT,OUTMSG,TMPMSG,LDNGSP
+ S LN="",CNT=0
+ F  S LN=$O(MSG(LN)) Q:LN=""  D  ;
+ . ;
  . ; Find any leading spaces in original message line, 
  . ; to be used if line got split below
  . S TMPMSG=$$TRIM^XLFSTR(MSG(LN),"L"," ")  ;Trim Leading Spaces
  . S LDNGSP=$P(MSG(LN),TMPMSG,1)  ;get leading spaces if any
- . S LDNGSPN=$L(LDNGSP) S:LDNGSPN>30 LDNGSP=$E(LDNGSP,1,30) ;make sure there are no more than 30 leading spaces 
+ . ;
  . ; Converts a single line to multiple lines with a maximum width of 70 each
  . ; If line is 70 chars or less, this call returns the exact line
- . K XARY D FSTRNG^IBJU1(TMPMSG,70-LDNGSPN,.XARY)
+ . K XARY D FSTRNG^IBJU1(MSG(LN),70,.XARY)
+ . ;
  . ; Scan lines and merge them into the final output array (OUTMSG)
  . ; On lines 2 and higher, add Leading Spaces found above, if any.
- . S XARYLN="" F  S XARYLN=$O(XARY(XARYLN)) Q:XARYLN=""  S CNT=CNT+1,OUTMSG(CNT)=LDNGSP_XARY(XARYLN)
+ . S XARYLN=""
+ . F  S XARYLN=$O(XARY(XARYLN)) Q:XARYLN=""  S CNT=CNT+1,OUTMSG(CNT)=$S(XARYLN=1:XARY(XARYLN),1:LDNGSP_XARY(XARYLN))
  ;
  ; Move the final Message Lines (OUTMSG) into MSG array to be returned
  K MSG M MSG=OUTMSG
- Q
- ;
+ Q  ;MSGLNSZ
+ ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCEU1 ;ALB/TMP - EDI UTILITIES FOR EOB PROCESSING ;10-FEB-99
- ;;2.0;INTEGRATED BILLING;**137,155,296,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**137,155,296,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -75,6 +75,5 @@
  . S (IBTOT,Z)=0
  . F  S Z=$O(^IBM(361.1,"ABS",IBIFN,IBCOBN,Z)) Q:'Z  D
- .. ; HD64841 IB*2*371 - total up the payer paid amounts
- .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,1)
+ .. S IBTOT=IBTOT+$P($G(^IBM(361.1,Z,1)),U,2)
  Q IBTOT
  ;
@@ -128,8 +127,5 @@
  Q
  ;
-COBOUT(IBXSAVE,IBXDATA,CL) ; build LCOB segment data
- ; The IBXSAVE array used here is built by INS-2, then LCOB-1.9
- ; This is basically the 361.115, but all the piece numbers here in this
- ; local array are one higher than the pieces in subfile 361.115.
+COBOUT(IBXSAVE,IBXDATA,CL) ;
  N Z,M,N,P,PCCL
  S (N,Z,P)=0 F  S Z=$O(IBXSAVE("LCOB",Z)) Q:'Z  D
@@ -143,10 +139,11 @@
  ;
 COBPYRID(IBXIEN,IBXSAVE,IBXDATA) ; cob insurance company payer id
- N CT,N,NUM
+ N CT,Z,N,NUM
  K IBXDATA
  I '$D(IBXSAVE("LCOB")) G COBPYRX
  D ALLPAYID^IBCEF2(IBXIEN,.NUM,1)
- S NUM=$G(NUM(1))
- S NUM=$E(NUM_$J("",5),1,5)
+ S Z=$$COID^IBCEF2(IBXIEN),NUM=$G(NUM(1))
+ S:Z="" Z="0000"
+ S NUM=$E(NUM_$J("",5),1,5)_$E(Z_$J("",4),1,4)
  S (CT,N)=0
  F  S N=$O(IBXSAVE("LCOB",N)) Q:'N  S CT=CT+1,IBXDATA(CT)=NUM
@@ -159,6 +156,5 @@
  ; The EOB is not eligible if the review status is not 3, or if there
  ; is no insurance sequence indicator, or if the EOB has been DENIED
- ; and the patient responsibility for that EOB is $0 and that EOB is
- ; not a split EOB.  Split EOB's need to be included (IB*2*371).
+ ; and the patient responsibility for that EOB is $0.
  ;
  NEW ELIG,IBDATA,PTRESP
@@ -167,10 +163,10 @@
  S IBDATA=$G(^IBM(361.1,IBEOB,0))
  I $P(IBDATA,U,4)'=1 G EOBELIGX      ; Only MRA EOB's for now
- I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX     ; filing error
  I $P(IBDATA,U,16)'=3 G EOBELIGX     ; review status - accepted-complete
  I '$P(IBDATA,U,15) G EOBELIGX       ; insurance sequence must exist
  S PTRESP=$P($G(^IBM(361.1,IBEOB,1)),U,2)     ; Pt Resp Amount for 1500s
  I $$FT^IBCEF(+IBDATA)=3 S PTRESP=$$PTRESPI^IBCECOB1(IBEOB)  ; for UBs
- I PTRESP'>0,$P(IBDATA,U,13)=2,'$$SPLIT^IBCEMU1(IBEOB) G EOBELIGX     ; Denied & No Pt. Resp. & not a split MRA
+ I PTRESP'>0,$P(IBDATA,U,13)=2 G EOBELIGX     ; Denied & No Pt. Resp.
+ I $D(^IBM(361.1,IBEOB,"ERR")) G EOBELIGX     ; filing error
  ;
  S ELIG=1
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU3.m	(revision 636)
@@ -1,5 +1,4 @@
-IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ;12/29/05 9:58am
- ;;2.0;INTEGRATED BILLING;**51,137,155,323,348,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCEU3 ;ALB/TMP - EDI UTILITIES FOR 1500 CLAIM FORM ; 12/29/05 9:58am
+ ;;2.0;INTEGRATED BILLING;**51,137,155,323,348**;21-MAR-94;Build 5
  ;
 BOX19(IBIFN) ; Returns the text that should print in box 19 of the CMS-1500
@@ -30,8 +29,4 @@
  S IBSPEC=$$BILLSPEC(IBIFN)
  G:'IBPRT NPRT
- ; Check for chiropractic services
- I $P($G(^DGCR(399,IBIFN,"U3")),U,5)'="" S:$P($G(^DGCR(399,IBIFN,"U3")),U,4)'="" IBGO=$$LENOK("Last X-ray: "_$TR($$DATE^IBCF2($P(^DGCR(399,IBIFN,"U3"),U,4))," ","/"),.IB19)
- G:'IBGO BOX19Q
- ;
  I "^25^65^73^67^48^"[(U_IBSPEC_U) D
  . K IBXDATA D F^IBCEF("N-DATE LAST SEEN",,,IBIFN)
@@ -59,5 +54,13 @@
  . ;
  . Q:'IBGO
- . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19) Q
+ . I 'IBHOSP,$P($G(IBXSAVE(IBSUB,Z,"AUX")),U,3) D  Q
+ .. S IBHOSP=1,IBGO=$$LENOK("Attending physician,not hospice employee",.IB19)
+ . ;
+ . Q:'IBGO
+ . I 'IBXRAY,IBSPEC=35,$G(IBXSAVE(IBSUB,Z,"AUX"))'="" D  Q
+ .. ; Check for chiropratic services in claim type or specialty
+ .. S IBXRAY=1
+ .. S IBGO=$$LENOK($S($P(IBXSAVE(IBSUB,Z,"AUX"),U,2):"Last Xray:"_$$DATE^IBCF2($P(IBXSAVE(IBSUB,Z,"AUX"),U,2),0,1)_" ",1:"")_$S($P(IBXSAVE(IBSUB,Z,"AUX"),U,4)'="":"Level of Sublux:"_$P(IBXSAVE(IBSUB,Z,"AUX"),U,4),1:""),.IB19)
+ ;
  G:'IBGO BOX19Q
  K IBXDATA D F^IBCEF("N-SPECIAL PROGRAM",,,IBIFN)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEU6.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCEU6 ;ALB/ESG - EDI UTILITIES FOR EOB PROCESSING ;29-JUL-2003
- ;;2.0;INTEGRATED BILLING;**155,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**155**;21-MAR-94
+ ;
  Q
  ;
@@ -45,5 +45,4 @@
  F  S A=$O(^IBM(361.1,"B",IBIFN,A)) Q:'A  D
  . I '$$EOBELIG^IBCEU1(A) Q   ; eob not eligible for secondary claim
- . I '$D(^IBM(361.1,A,15,"AC",IBI)) Q   ; this EOB does not reference VistA line# IBI
  . S IBA=0
  . S IBDATA=$G(^IBM(361.1,A,0))
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEXTRP.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ;4/22/03 9:59am
- ;;2.0;INTEGRATED BILLING;**137,197,211,348,349,377**;21-MAR-94;Build 23
+IBCEXTRP ;ALB/JEH - VIEW/PRINT EDI EXTRACT DATA ; 4/22/03 9:59am
+ ;;2.0;INTEGRATED BILLING;**137,197,211,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -6,5 +6,5 @@
 INIT ;
  W !!,"This option will display the EDI extract data for a bill.",!
- N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM,IBSEG,STOP,POP,DTOUT,DUOUT
+ N IBREC1,IBIEN,IBINC,DIC,X,Y,DIR,IB364IEN,IBVNUM
  ;
  N DPTNOFZY S DPTNOFZY=1 ; Suppress PATIENT file fuzzy lookups
@@ -17,38 +17,9 @@
  . W !!,"There is no batch # for this bill.  It has not been transmitted."
  S IBVNUM=$P($G(^IBA(364.1,IBVNUM,0)),U)
- S DIR("A")="Include Fields With No Data?: ",DIR("B")="NO",DIR(0)="YA"
- W ! D ^DIR K DIR
+ S DIR("A")="INCLUDE FIELDS WITH NO DATA?: ",DIR("B")="NO",DIR(0)="YA" D ^DIR K DIR
  I $D(DTOUT)!$D(DUOUT) G EXITQ
  S IBINC=+Y
- ;
- ; IB*2*377 - esg - Ask for specific EDI segments to view
- ;
- W !
- S DIR(0)="SA^A:All EDI Segments;S:Selected EDI Segments"
- S DIR("A")="Include (A)ll or (S)elected EDI Segments?: "
- S DIR("B")="All EDI Segments"
- D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT) G EXITQ
- I Y="A" G DEV                    ; all segments, skip to device prompt
- ;
- W !
- K IBSEG
- S STOP=0
- F  D  Q:STOP
- . S DIR(0)="FO^3:4"
- . S DIR("A")=" Select EDI Segment"
- . I $D(IBSEG) S DIR("A")="Another EDI Segment"
- . S DIR("?")="Enter the name of the EDI segment to include."
- . D ^DIR K DIR
- . I $D(DTOUT)!$D(DUOUT) S STOP=1 Q
- . S Y=$$UP^XLFSTR(Y),Y=$$TRIM^XLFSTR(Y)   ; uppercase/trim spaces
- . I Y="" S STOP=1 Q
- . S IBSEG(Y)=""
- . Q
- I $D(DTOUT)!$D(DUOUT) G EXITQ
- ;
 DEV ; - Select device
  N %ZIS,ZTRTN,ZTSAVE,ZTDESC
- W !
  S %ZIS="QM" D ^%ZIS G:POP EXITQ
  I $D(IO("Q")) D  G EXITQ
@@ -69,41 +40,16 @@
  S IBFMTYP=$S(IBFMTYP=2:"CMS-1500",IBFMTYP=3:"UB-04",1:"OTHER"_"("_IBFMTYP_")")
  S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
- ;
  I $D(^TMP("IBXERR",$J)) D  G EXITQ
  . S IBERR=0 F  S IBERR=$O(^TMP("IBXERR",$J,IBERR)) Q:'IBERR  W !,$G(^TMP("IBXERR",$J,IBERR))
- . Q
- ;
- F  S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ  I $$INCLUDE(IBSEQ) F  S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC  F  S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA  D
- . N IBOK,Z,IBMULT,DSP,IBDATA,PCD,SN
- . S IBREC=$G(^IBA(364.6,IBDA,0))
- . I $P(IBREC,U,11)=1 Q     ; calculate only field
- . ;
- . ; processing for piece 1 of this EDI segment to see if there is any
- . ; other data that exists in this segment
+ F  S IBSEQ=$O(^IBA(364.6,"ASEQ",8,IBSEQ)) Q:'IBSEQ!(IBQUIT)  F  S IBPC=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC)) Q:'IBPC!(IBQUIT)  F  S IBDA=$O(^IBA(364.6,"ASEQ",8,IBSEQ,1,IBPC,IBDA)) Q:'IBDA!(IBQUIT)  S IBREC=$G(^IBA(364.6,IBDA,0)) D  Q:IBQUIT
+ . N IBOK,Z,IBMULT
+ . I $P(IBREC,U,11)=1 Q
  . I IBPC=1 S IBOK=0 D
  .. S Z=1 F  S Z=$O(^TMP("IBXDATA",$J,1,IBSEQ,1,Z)) Q:'Z  I $G(^(Z))'="" S IBOK=1 Q
- .. I IBOK Q   ; data exists so include segment normally
- .. S SN=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U,1)   ; segment name
- .. I SN="" S SN=$P($P(IBREC,U,10),"'",2)
- .. S SN=SN_" (No Data - Record Not Sent)"
- .. S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U,1)=SN
- .. Q
- . ;
- . ; loop thru all multiple occurrences of this segment
+ .. I 'IBOK S $P(^TMP("IBXDATA",$J,1,IBSEQ,1,1),U)=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,1,1)),U)_"  (NO DATA - RECORD NOT SENT)"
  . S IBMULT=0 F  S IBMULT=$O(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT)) Q:'IBMULT   D
- .. ;
- .. ; field with no data; check user preference
- .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)="" Q
- .. ;
- .. ; build display data
- .. S PCD="["_IBPC_"] "      ; piece#
- .. S DSP=$P(IBREC,U,10)     ; short description field
- .. S IBDATA=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U,1)   ; data
- .. S DSP=$J(PCD,5)_$$FO^IBCNEUT1(DSP,40)_": "_IBDATA
- .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=DSP
- .. Q
- . Q
- ;
- S IBQUIT=0
+ .. I '$G(IBINC),$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)="" Q
+ .. S ^TMP($J,"IBLINES",IBSEQ,IBMULT,IBPC)=$E($P(IBREC,U,10)_$J("",30),1,30)_": "_$P($G(^TMP("IBXDATA",$J,1,IBSEQ,IBMULT,IBPC)),U)
+ .
  W:$E(IOST,1,2)["C-" @IOF ; initial form feed for screen print
  N IBFMTYP S IBFMTYP=$$FT^IBCEF(IBIEN)
@@ -111,17 +57,10 @@
  S IBILL=$S($$INPAT^IBCEF(IBIEN,1):"Inpt",1:"Oupt")_"/"_IBFMTYP
  D HDR
- S Z=0 F  S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z!IBQUIT  S Z0=0 F  S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0!IBQUIT  S Z1=0 F  S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1!IBQUIT  D  Q:IBQUIT
- . I IBLINE>(IOSL-3) D HDR Q:IBQUIT
+ S Z=0 F  S Z=$O(^TMP($J,"IBLINES",Z)) Q:'Z  S Z0=0 F  S Z0=$O(^TMP($J,"IBLINES",Z,Z0)) Q:'Z0  S Z1=0 F  S Z1=$O(^TMP($J,"IBLINES",Z,Z0,Z1)) Q:'Z1  D  G:IBQUIT Q1
+ . D:IBLINE>(IOSL-5) HDR Q:IBQUIT
  . W !,^TMP($J,"IBLINES",Z,Z0,Z1)
  . S IBLINE=IBLINE+1
- . I IBLINE>(IOSL-3) D HDR Q:IBQUIT
- . ;
- . ; end of segment add an extra line feed
- . I '$O(^TMP($J,"IBLINES",Z,Z0,Z1)) W ! S IBLINE=IBLINE+1
- . Q
- ;
- K ^TMP($J,"IBLINES")
- G EXITQ
- ;
+Q1 K ^TMP($J,"IBLINES")
+ Q
  ;
 HDR ; - Report header
@@ -132,12 +71,19 @@
  ;
  S IBPG=IBPG+1
- W !,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG
+ W !!,?25,"EDI Transmitted Bill Extract Data",!,"Bill #",?11,"Type",?27,"Patient Name",?52,"SSN",?57,$$FMTE^XLFDT(DT),?71,"Page: "_IBPG
  W !,$TR($J("",IOM)," ","=")
  W !,$P(IBREC1,U)_" "_"("_IBILL_")",?27,$P($G(^DPT(+$P(IBREC1,U,2),0)),U),?52,$P($G(^DPT($P(IBREC1,U,2),0)),U,9),!
- S IBLINE=6
+ S IBLINE=5
+ Q
+ ;
+ASK ;
+ I $E(IOST,1,2)'["C-" Q
+ N DIR,DIROUT,DIRUT,DTOUT,DUOUT
+ S DIR(0)="E" D ^DIR
+ I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1
  Q
  ;
 EXITQ ; - clean up and exit
- I $E(IOST,1,2)["C-",'$G(IBQUIT) K DIR S DIR(0)="E" W ! D ^DIR K DIR
+ I $E(IOST,1,2)["C-" K DIR S DIR(0)="E" W ! D ^DIR K DIR
  K ^TMP("IBXERR",$J),^TMP("IBXDATA",$J),IBXERR
  D CLEAN^DILF
@@ -150,5 +96,5 @@
  ; IBFORM = the ien of the form in file 353
  ; IBLOCAL = 1 if OK to use local form, 0 if not
- N IBVNUM,IBL,IBINC,IBSEG
+ N IBVNUM,IBL
  D FORMPRE^IBCFP1
  S IBVNUM=$G(IBBATCH)
@@ -160,14 +106,2 @@
  Q
  ;
-INCLUDE(IBSEQ) ; Function to determine if segment should be included or not
- N OK,LZ,SEGNAME
- S OK=1                   ; default is to include it
- I '$D(IBSEG) G INCLX     ; if nothing in array, then include all
- I '$D(^TMP("IBXDATA",$J,1,IBSEQ)) S OK=0 G INCLX        ; no data there
- S LZ=+$O(^TMP("IBXDATA",$J,1,IBSEQ,""))   ; first line# found in data
- S SEGNAME=$P($G(^TMP("IBXDATA",$J,1,IBSEQ,LZ,1)),U,1)   ; piece 1
- S SEGNAME=$$TRIM^XLFSTR(SEGNAME)
- I SEGNAME'="",'$D(IBSEG(SEGNAME)) S OK=0   ; don't include
-INCLX ;
- Q OK
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF331.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCF331 ;ALB/ARH - UB92 HCFA-1450 (GATHER CODES CONT) ;25-AUG-1993
- ;;2.0;INTEGRATED BILLING;**52,210,309,389**; 21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,210,309**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;
@@ -32,5 +32,5 @@
  S IBZ="PROSTHETIC ITEMS:" D SET2
  S IBX=0 F  S IBX=$O(IBARRAY(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(IBARRAY(IBX,IBY)) Q:'IBY  D
- . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($$PINB^IBCSC5B(+IBARRAY(IBX,IBY)),1,54) D SET2
+ . S IBZ=$$FMTE^XLFDT(IBX,2)_" "_$J($S($P(IBARRAY(IBX,IBY),U,2):"$"_$FN($P(IBARRAY(IBX,IBY),U,2),",",2),1:""),10)_"  "_$E($P($$PIN^IBCSC5B(IBY),U,2),1,54) D SET2
  ;
 END Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCF4.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCF4 ;ALB/ARH - PRINT BILL ADDENDUM ;12-JAN-94
- ;;2.0;INTEGRATED BILLING;**52,137,199,309,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,137,199,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 PRXA ;get bill number then print rx refill addendums for bills
@@ -56,5 +56,5 @@
  . S IBY=$G(^IBA(362.5,IBPIFN,0)),IBYC="" Q:IBY=""
  . S IBYC=$$CHG(IBPIFN,5,.IBRC)
- . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$E($P(IBY,U,5),1,55)
+ . W !,$$FMTE^XLFDT(+$P(IBY,U,1),2),?11,$J($S(IBYC:"$"_$FN(IBYC,",",2),1:""),10),?24,$P($$PIN^IBCSC5B(+$P(IBY,U,3)),U,2)
  . S IBLN=IBLN+1 I IBLN>(IOSL-7) D PAUSE,HDR
  D:'IBQUIT PAUSE
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNADD.m	(revision 636)
@@ -1,29 +1,14 @@
 IBCNADD ;ALB/AAS - ADDRESS RETRIEVAL ENGINE FOR FILE 399 ; 29-AUG-93
- ;;2.0;INTEGRATED BILLING;**52,80,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
-ADD(DA,IBCOB) ; -- Retrieve correct billing address for a bill, mailing address of Bill Payer
+ADD(DA) ; -- Retrive correct billing address for a bill, mailing address of Bill Payer
  ;    assumes that new policy field points to valid ins. policy
- ;    DA = ien to file 399
- ;    IBCOB = payer sequence PST or 123 (optional)
- ;
  N X,Y,I,J,IB01,IB02,IBTYP,DFN,IBCNS,IBCDFN,IBCNT,IBAGAIN,IBFND,IBBILLTY,IBCHRGTY
  S IB02=""
  S DFN=$P($G(^DGCR(399,DA,0)),"^",2)
+ S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1) G:'IBCNS MAINQ
+ S IBCDFN=$P($G(^DGCR(399,DA,"MP")),"^",2) I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0))
  S IBBILLTY=$P($G(^DGCR(399,DA,0)),"^",5),IBCHRGTY=$P($$CHGTYPE^IBCU(DA),"^;",1)
- ;
- S IBCNS=+$P($G(^DGCR(399,DA,"MP")),U,1)
- S IBCDFN=$P($G(^DGCR(399,DA,"MP")),U,2)
- ;
- ; If a specific payer sequence was passed in, get the ins. company and the policy ptr
- ; No address returned for Medicare
- I $G(IBCOB)'="" D  I $$MCRWNR^IBEFUNC(IBCNS) G MAINQ
- . S IBCOB=$TR(IBCOB,"PST","123")
- . S IBCNS=+$P($G(^DGCR(399,DA,"I"_IBCOB)),U,1)
- . S IBCDFN=+$P($G(^DGCR(399,DA,"M")),U,IBCOB+11)
- . Q
- ;
- I 'IBCNS G MAINQ
- I IBCDFN S IBCNS=+$G(^DPT(+DFN,.312,+IBCDFN,0))
  I '$D(^DIC(36,+IBCNS,0)) G MAINQ
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBCD.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCNBCD ;ALB/ARH-Ins Buffer: display/compare buffer and existing ins ;1 Jun 97
- ;;2.0;INTEGRATED BILLING;**82,251,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**82,251,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -78,5 +78,4 @@
  D DISPLAY(60.12,2.312,.2,"Coor of Benefits:")
  D DISPLAY(61.01,2.312,2.1,"Emp Sponsored?:")
- D DISPLAY(62.01,2.312,5.01,"Patient Id:")
  ;
  I +$G(^IBA(355.33,IBBUFDA,61))!($$GET1^DIQ(2.312,IBEXTDA,2.1)="YES") D ESGHP
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBEE.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCNBEE ;ALB/ARH-Ins Buffer: add/edit existing entries in buffer ;1 Jun 97
- ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361,371,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**82,184,252,251,356,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -157,6 +157,6 @@
  ;;40.01:40.03;40.1;40.11;40.09;40.04:40.08
  ;
-MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP,60.05,60.06 60.02-61.01
- ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112;60.1:60.12;.03;61.01
+MRPOL ; Patient Policy fields asked of MCCR users in the Buffer Process options (all buffer policy fields except ESGHP 60.02-61.01
+ ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112;60.1:60.12;.03;61.01
  ;
 OTINS ; Insurance Company fields asked of non-MCCR users entering buffer data from options outside IB (20.01-20.04,21.01-21.06)
@@ -166,4 +166,4 @@
  ;;40.02;40.03;40.1;40.11;40.09
  ;
-OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.08)
- ;;60.02;60.03;60.14PT. RELATIONSHIP TO INSURED;S IBZZ=X;60.04T;I IBZZ'="18" S Y="@111";60.07///1;60.08///@;60.09///@;62.01///@;S Y="@112";@111;60.07;60.08;60.13;62.01T;@112
+OTPOL ; Patient Policy fields asked of non-MCCR users entering buffer data from options outside IB (60.02-60.09)
+ ;;60.02;60.03;60.05;60.06//^S X=$S(X="v":"01",X="s":"02",1:"");S IBZZ=X;60.04;I IBZZ'="01" S Y="@111";60.07///1;60.08///@;60.09///@;S Y="@112";@111;60.07:60.09;60.13;@112
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBLE.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCNBLE ;ALB/ARH-Ins Buffer: LM buffer entry screen ;1 Jun 97
- ;;2.0;INTEGRATED BILLING;**82,231,184,251,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**82,231,184,251**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 EN ; - main entry point for list manager display
@@ -41,8 +41,7 @@
  ;
 BLD ; display buffer entry
- N IB0,IB20,IB40,IB60,IB61,IB62,IBL,IBLINE,ADDR,IBI,IBY
+ N IB0,IB20,IB40,IB60,IB61,IBL,IBLINE,ADDR,IBI,IBY
  S VALMCNT=0
- S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40))
- S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61)),IB62=$G(^IBA(355.33,IBBUFDA,62))
+ S IB0=$G(^IBA(355.33,IBBUFDA,0)),IB20=$G(^IBA(355.33,IBBUFDA,20)),IB40=$G(^IBA(355.33,IBBUFDA,40)),IB60=$G(^IBA(355.33,IBBUFDA,60)),IB61=$G(^IBA(355.33,IBBUFDA,61))
  ;
  D SET(" ") S IBY=$J("",26)_"Insurance Company Information" D SET(IBY,"B") S IBLINE=""
@@ -98,5 +97,5 @@
  S IBL="Coord of Benefits: ",IBY=$$EXPAND^IBTRE(355.33,60.12,$P(IB60,U,12)) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,16)
  D SET(IBLINE) S IBLINE=""
- I $P(IB62,U)'="" S IBL="Patient Id: ",IBY=$P(IB62,U) S IBLINE=$$SETL(IBLINE,IBY,IBL,62,13)
+ I $P(IB60,U,6)'="01"!($P(IB60,U,9)'="") S IBL="Insured's SSN: ",IBY=$P(IB60,U,9) S IBLINE=$$SETL("",IBY,IBL,18,13)
  I IBLINE'="" D SET(IBLINE) S IBLINE=""
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNBMI.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ;09 Mar 2005  11:42 AM
- ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361,371**;21-MAR-94;Build 57
+IBCNBMI ;ALB/ARH-Ins Buffer: move buffer data to insurance files ; 09 Mar 2005  11:42 AM
+ ;;2.0;INTEGRATED BILLING;**82,184,246,251,299,345,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -120,5 +120,5 @@
  ;
 POLDR ;
- ;;2.312^60.02:62.01^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08;5.01
+ ;;2.312^60.02:61.12^8;3;1;6;16;17;3.01;3.05;4.01;4.02;.2;3.12;2.1;2.015;2.11;2.12;2.01:2.08
 POLFLD ; corresponding fields:  Buffer File (355.33) and Insurance Patient Policy file (2.312)
  ;;60.02^8^Effective Date^            ; Effective Date
@@ -147,5 +147,4 @@
  ;;61.11^2.07^Emp Zip Code^1          ; Employer Claims Zip Code
  ;;61.12^2.08^Emp Phone^              ; Employer Claims Phone
- ;;62.01^5.01^Patient Id^             ; Patient Id
  ;
 POLA ; auto set fields
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEBF.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCNEBF ;DAOU/ALA - Create an Entry in the Buffer File ;20-JUN-2002
- ;;2.0;INTEGRATED BILLING;**184,271,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**184,271,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -23,5 +23,5 @@
  ;
  ;
- NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID
+ NEW VBUF,IEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE
  NEW BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
  NEW MSG,XMSUB,MSGP,INSDATA,PCE,BFD,BFN,INSPCE,ESGHPARR
@@ -33,5 +33,4 @@
  S NAME=$P($G(^DPT(DFN,.312,IRIEN,0)),U,17)
  S SUBID=$P($G(^DPT(DFN,.312,IRIEN,0)),U,2)
- S PATID=$P($G(^DPT(DFN,.312,IRIEN,5)),U,1)
  S WHO=$P($G(^DPT(DFN,.312,IRIEN,0)),U,6)
  S COB=$P($G(^DPT(DFN,.312,IRIEN,0)),U,20)
@@ -83,5 +82,4 @@
  S COB=$P(RDATA,U,13)
  S SUBID=$P(RDATA,U,5)
- S PATID=$P(RDATA,U,18)
  S GNAME=$P(RDATA,U,6)
  S GNUMB=$P(RDATA,U,7)
@@ -93,5 +91,5 @@
  ;
  D FIL
- K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE,PATID
+ K DFN,VBUF,IEN,IRIEN,INAME,PNAME,IIEN,GNUMB,GNAME,SUBID,PPHONE
  K BPHONE,EFFDT,EXPDT,WHO,REL,IDOB,ISSN,COB,TQIEN,RDATA,ISEX,NAME
  K ADD,%DT,D0,DG,DIC,DISYS,DIW,IENS
@@ -117,5 +115,4 @@
  . S VBUF(60.07)=NAME  ; Name of Insured
  . S VBUF(60.04)=SUBID  ; Subscriber ID
- . S VBUF(62.01)=PATID  ; Patient/Member ID
  . S VBUF(20.04)=PPHONE  ; Precertification Phone
  . S VBUF(20.03)=BPHONE  ; Billing Phone
@@ -156,5 +153,5 @@
  . S MSG(4)=" Patient DFN = "_$G(DFN)
  . S MSG(5)=" Pt Ins Record IEN = "_$G(IRIEN)
- . S MSG(6)="Please log a Remedy Ticket for this problem."
+ . S MSG(6)="Please log a NOIS for this problem."
  . S XMSUB="Error creating Buffer Entry."
  . D MSG^IBCNEUT5(MSGP,XMSUB,"MSG(")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNQ.m	(revision 636)
@@ -1,5 +1,23 @@
-IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;13 JUN 88 13:52
- ;;2.0;INTEGRATED BILLING;**51,320,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNQ ;ALB/MJB - MCCR PATIENT BILLING INQUIRY ;7:37 PM  30 Jan 2008
+ ;;2.0;INTEGRATED BILLING;**51,320;VWEHR1**;WorldVistA 30-Jan-08
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ;MAP TO DGCRNQ
@@ -11,4 +29,5 @@
 VIEW ;
  ;***
+ ;S XRTL=$ZU(0),XRTN="IBCNQ-2" D T0^%ZOSV ;start rt clock
  F I=0,"S","U","U1" S IB(I)=$G(^DGCR(399,IBIFN,I))
  S DFN=$P(IB(0),"^",2),IBSTAT=$P(IB(0),"^",13),IBBNO=$$BN^PRCAFN(IBIFN),IBPAGE=0 S:IBBNO=-1 IBBNO=$S($D(IBIL):IBIL,1:$P(IB(0),"^"))
@@ -17,5 +36,5 @@
  ;
  S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
- W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT=1:"",1:"UN"),"EDITABLE"
+ W !,"Bill Status",?15,": ",$S(IBSTAT=1:"ENTERED/NOT REVIEWED",IBSTAT=2:"MRA REQUESTED",IBSTAT=3:"AUTHORIZED",IBSTAT=4:"PRINTED/TRANSMITTED",IBSTAT=7:"CANCELLED",1:IBUN)," - RECORD IS ",$S(IBSTAT<3:"",1:"UN"),"EDITABLE"
  W !,"Rate Type",?15,": ",$S($P(IB(0),"^",7)="":IBUN,'$D(^DGCR(399.3,$P(IB(0),"^",7),0)):IBUN,1:$P(^DGCR(399.3,$P(IB(0),"^",7),0),"^"))
  W:+$P(^IBE(350.9,1,1),"^",22) !,"Form Type",?15,": ",$S($P($G(^IBE(353,+$P(IB(0),"^",19),0)),"^")]"":$P(^(0),"^"),1:IBUN)
@@ -38,6 +57,6 @@
  S IBUN="UNSPECIFIED",IBUK="UNKNOWN USER"
  I IB("S")']"" W !,"Past actions of this billing record unspecified." G DISPQ
- S IBX="Entered^^^^^^MRA Requested^^^Authorized^^First Printed^^Last Printed^^^Cancelled"
- F I=1,7,10,12,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  D DISP1
+ S IBX="Entered^^^^^^MRA Requested^^^Authorized^^^^Last Printed^^^Cancelled"
+ F I=1,10,14,17 I $P(IB("S"),U,I)]"" D:IBAC[7&($Y>(IOSL-4)) HDR Q:$S(IBAC'[7:0,1:IBQUIT)  D DISP1
  ;
  ;Patch 320 - Added call to retrieve claim clone history.
@@ -59,5 +78,12 @@
  ; now go backwards for claim cloning history all the way back
  S IBBCH=IBCURR
- F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ ;
+ ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ ;
+ ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
+ . ;
+ . ;END CHANGE
+ . ;
  . N IBX,TS1,TS2 S IBX=@IBBCH
  . I IBINDENT S TS1=4,TS2=19     ; set tab stops
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNRDV.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV ;27-MAR-03
- ;;2.0;INTEGRATED BILLING;**214,231,361,371**;21-MAR-94;Build 57
+IBCNRDV ;OAKFO/ELZ - INSURANCE INFORMATION EXCHANGE VIA RDV;27-MAR-03
+ ;;2.0;INTEGRATED BILLING;**214,231,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -94,5 +94,5 @@
  S IBD(0)=$G(IBY(0))
  ;
- ; where n starts at 1 and increments to 7 for each insurance company
+ ; where n starts at 1 and increments 6 for each insurance company
  ; IBD(n) = 355.33, zero node format
  ; IBD(n+1) = 355.33, 20 node format
@@ -101,5 +101,4 @@
  ; IBD(n+4) = 355.33, 60 node format
  ; IBD(n+5) = 355.33, 61 node format
- ; IBD(n+6) = 355.33, 62 node format
  ;
  S IBP="|"
@@ -107,5 +106,5 @@
  . S IBZ=$P($G(IBY(IBI,+IBT)),"^",$P(IBT,IBP,2)) ; set the existing data
  . I $L($P(IBT,IBP,6)) X $P(IBT,IBP,6) ; output transform
- . S $P(IBD(IBI-1*7+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD
+ . S $P(IBD(IBI-1*6+$P(IBT,IBP,3)),"^",$P(IBT,IBP,4))=IBZ ; set data IBD
  Q
  ;
@@ -141,5 +140,4 @@
  ;;4|1|5|10|60.1;primary care provider
  ;;4|2|5|11|60.11;primary provider phone
- ;;5|1|7|1|62.01;patient id
  ;;355.3|2|4|1|40.01;is this a group policy
  ;;355.3|3|4|2|40.02;group name
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNS1.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
- ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 INSURED(DFN,IBINDT) ; -- Is patient insured
@@ -108,5 +108,4 @@
  ;           var(x,3) =: ^dpt(dfn,.312,x,3)
  ;           var(x,4) =: ^dpt(dfn,.312,x,4)
- ;           var(x,5) =: ^dpt(dfn,.312,x,5)
  ;       var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
  ;       var("S",COB sequence,x) =: (null) as an xref for COB
@@ -123,5 +122,4 @@
  .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
  .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
- .S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5))
  .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0))
  .I $G(SOP) D
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC.m	(revision 636)
@@ -1,5 +1,5 @@
-IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 9:42am
- ;;2.0;INTEGRATED BILLING;**46,137,184,276,320,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 9:42am
+ ;;2.0;INTEGRATED BILLING;**46,137,184,276,320**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;also used for IA #4694
@@ -47,5 +47,5 @@
  N OFFSET,START,IBCNS14,IBADD
  S IBCNS14=$$ADDRESS^IBCNSC0(IBCNS,.14,7)
- S START=48,OFFSET=2
+ S START=40,OFFSET=2
  D SET^IBCNSP(START,OFFSET+25," Appeals Office Information ",IORVON,IORVOFF)
  D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS14,"^",7),0)),"^",1))
@@ -63,5 +63,5 @@
  N OFFSET,START,IBCNS15,IBADD
  S IBCNS15=$$ADDRESS^IBCNSC0(IBCNS,.15,8)
- S START=55,OFFSET=2
+ S START=47,OFFSET=2
  D SET^IBCNSP(START,OFFSET+25," Inquiry Office Information ",IORVON,IORVOFF)
  D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS15,"^",7),0)),"^",1))
@@ -109,22 +109,2 @@
  Q OK
  ;
-DUPQUAL(IBCNS,QUAL,FIELD) ; input transform to make sure that the sam qualifier is not used twice for
- ; payer secondary IDs.  There are two sets of fields in file 36 that can not be duplicated.
- ; 6.01 EDI INST SECONDARY ID QUAL(1) can not be the same as 6.03 EDI INST SECONDARY ID QUAL(2)
- ; 6.05 EDI PROF SECONDARY ID QUAL(1) can not be the same as 6.07 EDI PROF SECONDARY ID QUAL(2)
- ; 
- ; Input:
- ; IBCNS is the insurance company internal number
- ; QUAL  is the internal code of the value being input.
- ; FIELD is the field it is being compare with.
- ;
- ; Returns:
- ; TRUE/1 if they are the same (duplicate)
- ; FALSE/0 if they are not
- ;
- Q:$G(QUAL)="" 0  ; should not happen because this is invoked as an input transform
- Q:'+$G(IBCNS) 1  ; stop from editing through fileman
- N DUP
- S DUP=$$GET1^DIQ(36,+$G(IBCNS)_",",+$G(FIELD),"I")
- D CLEAN^DILF
- Q QUAL=DUP
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC0.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC0.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC0.m	(revision 636)
@@ -1,9 +1,9 @@
-IBCNSC0 ;ALB/NLR - INSURANCE COMPANY EDIT -  ;12-MAR-1993
- ;;2.0; INTEGRATED BILLING ;**371**; 21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSC0 ;ALB/NLR - INSURANCE COMPANY EDIT -  ; 12-MAR-1993
+ ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 CLAIMS1 ; display Inpatient Claims information
  N OFFSET,START,IBCNS12,IBADD
- S START=27,OFFSET=2
+ S START=21,OFFSET=2
  D SET^IBCNSP(START,OFFSET+20," Inpatient Claims Office Information ",IORVON,IORVOFF)
  S IBCNS12=$$ADDRESS(IBCNS,.12,5)
@@ -22,5 +22,5 @@
  ;
  N OFFSET,START,IBCNS16,IBADD
- S START=34,OFFSET=2
+ S START=27,OFFSET=2
  D SET^IBCNSP(START,OFFSET+20," Outpatient Claims Office Information ",IORVON,IORVOFF)
  S IBCNS16=$$ADDRESS(IBCNS,.16,6)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC01.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC01.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC01.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 10:06am
- ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349,371**;21-MAR-94;Build 57
+IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ; 6/1/05 10:06am
+ ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -18,31 +18,21 @@
  D SET^IBCNSP(START+6,OFFSET+1,"Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9))
  D SET^IBCNSP(START+7,OFFSET+1,"Rx Refill Rev. Code: "_$P(IBCNS0,"^",15))
+ D SET^IBCNSP(START+8,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12))
+ D SET^IBCNSP(START+9,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
+ D SET^IBCNSP(START+10,OFFSET+3,"Primary Form Type: "_$$EXPAND^IBTRE(36,.14,$P(IBCNS0,"^",14)))
  ;
- S OFFSET=45
- D SET^IBCNSP(START+1,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12))
- D SET^IBCNSP(START+2,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
- D SET^IBCNSP(START+3,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
- D SET^IBCNSP(START+4,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
- D SET^IBCNSP(START+5,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
- D SET^IBCNSP(START+6,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
- I +IBCNS3=2 D SET^IBCNSP(START+7,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
- ;
- S START=11,OFFSET=2
- D SET^IBCNSP(START,OFFSET+28," EDI Parameters ",IORVON,IORVOFF)
- D SET^IBCNSP(START+1,OFFSET+13,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO"))
- D SET^IBCNSP(START+2,OFFSET+1,"Inst Payer Primary ID: "_$P(IBCNS3,U,4))
- D SET^IBCNSP(START+3,OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.01))
- D SET^IBCNSP(START+4,OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.02))
- D SET^IBCNSP(START+5,OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.03))
- D SET^IBCNSP(START+6,OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.04))
- D SET^IBCNSP(START+7,OFFSET+12,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3)) ;
- ;
- S OFFSET=41
- D SET^IBCNSP(START+1,OFFSET+8," Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
- D SET^IBCNSP(START+2,OFFSET+1," Prof Payer Primary ID: "_$P(IBCNS3,U,2))
- D SET^IBCNSP(START+3,OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.05))
- D SET^IBCNSP(START+4,OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.06))
- D SET^IBCNSP(START+5,OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.07))
- D SET^IBCNSP(START+6,OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.08))
+ N START,OFFSET
+ S START=1,OFFSET=45
+ D SET^IBCNSP(START+1,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
+ D SET^IBCNSP(START+2,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
+ D SET^IBCNSP(START+3,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
+ D SET^IBCNSP(START+4,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
+ D SET^IBCNSP(START+5,OFFSET+6,"   *** EDI Parameters ***   ",IOINHI,IOINORM)
+ D SET^IBCNSP(START+6,OFFSET+11,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",1:"NO"))
+ D SET^IBCNSP(START+7,OFFSET+7,"Inst Payer ID: "_$P(IBCNS3,U,4))
+ D SET^IBCNSP(START+8,OFFSET+7,"Prof Payer ID: "_$P(IBCNS3,U,2))
+ D SET^IBCNSP(START+9,OFFSET+6,"Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
+ D SET^IBCNSP(START+10,OFFSET+10,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3))
+ I +IBCNS3=2 D SET^IBCNSP(START+11,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
  Q
  ;
@@ -65,5 +55,5 @@
  S IBCNS11=$G(^DIC(36,+IBCNS,.11))
  S IBCNS13=$G(^DIC(36,+IBCNS,.13))
- S START=21,OFFSET=25
+ S START=15,OFFSET=25
  D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)
  N OFFSET S OFFSET=2
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC02.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCNSC02 ;ALB/ESG - Insurance Company parent/child management ;01-NOV-2005
- ;;2.0;INTEGRATED BILLING;**320,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**320**;21-MAR-1994
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  Q
@@ -11,5 +11,5 @@
  I PCFLG="P" S PCDESC="Parent"
  S TITLE=" Associated Insurance Companies "
- S (START,IBLINE)=62
+ S (START,IBLINE)=54
  S OFFSET=(40-($L(TITLE)/2))\1+1
  D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
- ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -40,6 +40,5 @@
  I $G(IBY)=",12," D FACID
  F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z)   ; save EDI data fields
- F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z)   ; save EDI data fields
- I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS)
+ I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1
  I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
  I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS)   ; parent/child management
@@ -57,5 +56,5 @@
  N OFFSET,START,IBCNS18,IBADD
  S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
- S START=41,OFFSET=2
+ S START=34,OFFSET=2
  D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
  D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
@@ -206,26 +205,2 @@
  I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
  Q X
- ;
-CUIDS(IBCNS) ;
- N DIE,DA,DR,PIECE,DAT6,Y
- S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs
- ;
- ; Make sure each qualifier has an ID and vice versa
- F PIECE=1,3,5,7 D
- . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q  ; both blank
- . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q  ; both have data
- . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
- . D ^DIE K DIE
- ;
- S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.
- ;
- ; Make sure the first pair of ID/Qual are populated if the 2nd pair is.  If not, move em over.
- ; This is done for institutional then professional
- F PIECE=1,5 D
- . I $P(DAT6,U,PIECE)]"" Q  ; already has set one
- . I $P(DAT6,U,PIECE+2)="" Q  ; has no second set
- . S DIE="^DIC(36,",(DA,Y)=IBCNS
- . ; deleting the qualifier triggers deletion of the ID
- . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
- . D ^DIE K DIE
- Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSEH.m	(revision 636)
@@ -1,5 +1,5 @@
-IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT ;28-MAY-93
- ;;2.0;INTEGRATED BILLING;**6,28,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSEH ;ALB/AAS - EXTENDED HELP FOR INSURANCE MANAGEMENT - 28-MAY-93
+ ;;Version 2.0 ; INTEGRATED BILLING ;**6,28**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 INS ; -- Help for Insurance Type
@@ -14,5 +14,10 @@
 PAT ; -- Help for entering patient specific information
  Q:'$G(IBCNSEH)
- W !!,"Now you may enter the patient specific policy information.",!
+ W !!,"Now you may enter the patient specific policy information."
+ W !,"Most of these fields will be familiar to experienced users.  The field"
+ W !,"'SUBSCRIBER ID' used to be called 'INSURANCE NUMBER' and "
+ W !,"has been modified to allow entering just 'SS' to retrieve"
+ W !,"the patients SSN.  This field is the identifier for the policy or patient"
+ W !,"that the carrier uses.  See the new help.",!
  Q
 POL ; -- Help for policy specific information
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSM32.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ;23-JAN-95
- ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361,371**;21-MAR-94;Build 57
+IBCNSM32 ;ALB/AAS - INSURANCE MANAGEMENT - POLICY EDIT ; 23-JAN-95
+ ;;2.0;INTEGRATED BILLING;**28,40,52,85,103,133,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -13,10 +13,12 @@
  ;
  N IBAD,IBDIF,DA,DR,DIC,DIE,DGSENFLG S DGSENFLG=1
+ S DIE="^DPT("_DFN_",.312,",DA(1)=DFN,DA=IBCDFN
+ S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01"""
+ ;S DR="S IBAD="""";8;@333;3;D FUTURE^IBCNSM31;6;S IBAD=X;I IBAD'=""v"" S Y=""@10"";17"_$S($$VET^IBCNSU1():"///^S X="""_$P(^DPT(DFN,0),U,1)_"""",1:"//"_);16///^S X=""01"""
+ S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;3.01;3.12;1.09//;I $G(IBREG) S Y=""@99"";.2;4.01;4.02;@99"
+ I $G(IBREG),$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) S DR=".01//;"_DR
  L +^DPT(DFN,.312,+IBCDFN):5 I '$T D LOCKED^IBTRCD1 G PATPOLQ
- ;
- D EDIT^IBCNSP1(DFN,IBCDFN,.IBQUIT)    ; IB*371 edit 2.312 subfile data
- ;
- ; If the 2.312 subfile entry was deleted then unlock and get out
- I '$D(^DPT(DFN,.312,IBCDFN,0)) L -^DPT(DFN,.312,+IBCDFN) G PATPOLQ
+ D ^DIE I $D(Y)!($D(DTOUT)) S IBQUIT=1
+ I '$D(DA) S IBQUIT=1 G PATPOLQ
  ;
  ; -- if the company was changed, change the policy plan
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP.m	(revision 636)
@@ -1,8 +1,7 @@
 IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
- ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
 % ;
 EN ; -- main entry point for IBCNS EXPANDED POLICY
- N IB1ST
  K VALMQUIT,IBPPOL
  S IBTOP="IBCNSP"
@@ -31,50 +30,33 @@
  K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J)
  D KILL^VALM10()
- F I=1:1:20 D BLANK(.I)    ; start with 20 blank lines
- N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4,IBCDFND5
- S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4)),IBCDFND5=$G(^(5))
+ F I=1:1:50 D BLANK(.I)
+ S VALMCNT=50
+ N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4
+ S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4))
  S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4)
  S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1))
  S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN
- ;
- D POLICY^IBCNSP0                   ; plan information
- D INS^IBCNSP0                      ; insurance company
- D UR                               ; utilization review info
- D EFFECT                           ; effective dates & source of info
- D SUBSC^IBCNSP01                   ; subscriber info
- D EMP                              ; subscriber's employer info
- D SPON^IBCNSP0                     ; insured person's info
- D ID^IBCNSP01                      ; ins co ID numbers (IB*2*371)
- D PLIM                             ; plan coverage limitations
- D VER^IBCNSP01                     ; user/verifier/editor info
- D CONTACT^IBCNSP0                  ; last insurance contact
- D COMMENT                          ; comments - policy & plan
- D RIDER^IBCNSP01                   ; policy rider info
- ;
- S VALMCNT=+$O(^TMP("IBCNSVP",$J,""),-1)
+ S IBLCNT=0
+ D POLICY^IBCNSP0,INS^IBCNSP0,SPON^IBCNSP0,LIMBLD^IBCNSC41(36,2,.IBLCNT)
+ D CONTACT^IBCNSP0,EFFECT,UR,EMP,VER^IBCNSP01,COMMENT,^IBCNSP01
  Q
  ;
 COMMENT ; -- Comment region
  N START,OFFSET,IBL,IBI
- S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
- S IB1ST("COMMENT")=START
+ S START=49+$G(IBLCNT),OFFSET=2,IBL=0
+ I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET,"  ")
  D SET(START,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF)
- S IBL=IBL+1
- D SET(IBL,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8)))
- S IBL=IBL+1
- D SET(IBL,OFFSET," ")
- S IBL=IBL+1
- D SET(IBL,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
+ D SET(START+1,OFFSET,$S($P(IBCDFND1,U,8)="":"None",1:$P(IBCDFND1,U,8)))
+ I '$D(@VALMAR@(START+2)) D SET(START+2,OFFSET,"  ")
+ D SET(START+3,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
  S IBI=0 F  S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1  D
- . S IBL=IBL+1
- . D SET(IBL,OFFSET,"  "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
- . Q
- S IBL=IBL+1 D SET(IBL,OFFSET," ")
- S IBL=IBL+1 D SET(IBL,OFFSET," ")
+ .S IBL=IBL+1
+ .D SET(START+IBL+3,OFFSET,"  "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
+ S IBLCNT=$G(IBLCNT)+IBL+1 D SET(START+IBL+4,OFFSET,"  ")
  Q
  ;
 EFFECT ; -- Effective date region
  N START,OFFSET
- S START=16,OFFSET=45
+ S START=14,OFFSET=45
  D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF)
  D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8)))
@@ -86,5 +68,5 @@
 UR ; -- UR of insurance region
  N START,OFFSET
- S START=16,OFFSET=2
+ S START=14,OFFSET=2
  D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF)
  D SET(START+1,OFFSET,"         Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5)))
@@ -96,5 +78,5 @@
 EMP ; -- Insurance Employer Region
  N OFFSET,START,IBADD
- S START=24,OFFSET=40
+ S START=19,OFFSET=40
  D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF)
  D SET(START+1,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No"))
@@ -103,4 +85,5 @@
  D SET(START+4,OFFSET,"   Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12)))
  D SET(START+5,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company"))
+ ;I +IBCDFND2 W !!,"If ROI applies, make sure current consent is signed.",!! D PAUSE^VALM1
  ;
  D SET(START+6,OFFSET,"            Street: "_$P(IBCDFND2,U,2)) S IBADD=1
@@ -110,19 +93,5 @@
  D SET(START+7+IBADD,OFFSET,"             Phone: "_$P(IBCDFND2,U,8))
  ;
- ; couple of blank lines to end this section
- D SET(START+8+IBADD,2," ")
- D SET(START+9+IBADD,2," ")
- ;
 EMPQ Q
- ;
-PLIM ; plan coverage limitations/plan limitation category display
- N START,END S START=$O(^TMP("IBCNSVP",$J,""),-1)+1
- S IB1ST("PLIM")=START
- D LIMBLD^IBCNSC41(START,2)
- S END=$O(^TMP("IBCNSVP",$J,""),-1)  ; last line constructed
- D SET(END+1,2," ")    ; 2 blank lines to end this section
- D SET(END+2,2," ")
-PLIMX ;
- Q
  ; 
 HELP ; -- help code
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP0.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
- ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363,371**;21-MAR-94;Build 57
+IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ;05-MAR-1993
+ ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363**;21-MAR-94;Build 35
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -6,11 +6,5 @@
 CONTACT ; -- Insurance Contact Information
  N OFFSET,START
- ;
- ; The start of this section is designed to start on the same line
- ; as the User Information section (see VER^IBCNSP01).
- ;
- S START=$O(^TMP("IBCNSVP",$J,""),-1)-8
- S IB1ST("CONTACT")=START
- S OFFSET=42
+ S START=41+$G(IBLCNT),OFFSET=42
  N IBTRC,IBTRCD,IBTCOD
  S IBTCOD=$O(^IBE(356.11,"ACODE",85,0))
@@ -22,4 +16,5 @@
  .S IBTRCD=$G(^IBT(356.2,+IBTRC,0))
  ;
+ I '$D(@VALMAR@(START-1)) D SET(START-1,OFFSET,"  ")
  D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF)
  D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6)))
@@ -28,6 +23,4 @@
  D SET(START+4,OFFSET,"    Call Ref. No.: "_$$EXPAND^IBTRE(356.2,.09,$P(IBTRCD,"^",9)))
  D SET(START+5,OFFSET,"     Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^")))
- ; no blank lines here because the User Information section is on the
- ; left and it is bigger than this section
  Q
  ;
@@ -51,11 +44,9 @@
  . D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1
  D SET(START+IBX,OFFSET,"  Plan Filing TF: "_$P(IBCPOLD,"^",13)) S IBX=IBX+1
- ;
+ ; -- in case pointer is missing
  D SET(START+IBX,OFFSET,"      ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1
  D SET(START+IBX,OFFSET,"    ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1
  D SET(START+IBX,OFFSET,"  ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1
  D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1
- ;
- ; -- in case pointer is missing
  I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D
  .D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
@@ -82,13 +73,13 @@
  ;
 SPON ; -- Sponsor (Insured Person) Region
- N IBC3,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ
- S IBC3=$G(^DPT(DFN,.312,IBCDFN,3))
+ N IBC3,IBSSN,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ
+ S IBC3=$G(^DPT(DFN,.312,IBCDFN,3)),IBSSN=$P(IBC3,"^",5)
  S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1
- S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=4
- D SET(START,OFFSET," Insured Person's Information (use Subscriber Update Action) ",IORVON,IORVOFF)
+ S START=30,OFFSET=4
+ D SET(START,OFFSET," Insured Person's Information (use Subscriber Update action) ",IORVON,IORVOFF)
  D SET(START+1,OFFSET,"    Insured's DOB: "_$$DAT3^IBOUTL($P(IBC3,"^")))
- D SET(START+2,OFFSET,"    Insured's Sex: "_$$EXTERNAL^DILFD(2.312,3.12,,$P(IBC3,U,12)))
- D SET(START+3,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E")))
- D SET(START+4,OFFSET,"   Insured's Rank: "_$P(IBC3,"^",3))
+ D SET(START+2,OFFSET," Insured's Branch: "_$G(IBA(23,DA,.01,"E")))
+ D SET(START+3,OFFSET,"   Insured's Rank: "_$P(IBC3,"^",3))
+ D SET(START+4,OFFSET,"    Insured's SSN: "_$S(IBSSN]"":$E(IBSSN,1,3)_"-"_$E(IBSSN,4,5)_"-"_$E(IBSSN,6,9),1:""))
  ;
  S OFFSET=43
@@ -99,8 +90,4 @@
  D SET(START+4,OFFSET,"St/Zip: "_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_"  "_IBZIP)
  D SET(START+5,OFFSET," Phone: "_$P(IBC3,"^",11))
- ;
- ; blank lines at end of section
- D SET(START+6,2," ")
- D SET(START+7,2," ")
  Q
  ;
@@ -115,5 +102,4 @@
  W:'(LINE#5) "."
  Q
- ;
 GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the
  ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP01.m	(revision 636)
@@ -1,5 +1,5 @@
-IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ;05-MAR-1993
- ;;2.0;INTEGRATED BILLING;**43,52,85,251,371,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSP01 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY  ; 05-MAR-1993
+ ;;2.0;INTEGRATED BILLING;**43,52,85,251**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;
@@ -9,12 +9,12 @@
 SUBSC ; -- subscriber region
  N OFFSET,START
- S START=24,OFFSET=2
+ S START=19,OFFSET=2
  D SET^IBCNSP(START,OFFSET," Subscriber Information ",IORVON,IORVOFF)
  S Y=$P(IBCDFND,"^",6),C=$P(^DD(2.312,6,0),"^",2) D Y^DIQ
  D SET^IBCNSP(START+1,OFFSET," Whose Insurance: "_Y)
  D SET^IBCNSP(START+2,OFFSET," Subscriber Name: "_$P(IBCDFND,"^",17))
- S Y=$P(IBCDFND4,"^",3),C=$P(^DD(2.312,4.03,0),"^",2) D Y^DIQ
+ S Y=$P(IBCDFND,"^",16),C=$P(^DD(2.312,16,0),"^",2) D Y^DIQ
  D SET^IBCNSP(START+3,OFFSET,"    Relationship: "_Y)
- D SET^IBCNSP(START+4,OFFSET,"      Primary ID: "_$P(IBCDFND,"^",2))
+ D SET^IBCNSP(START+4,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
  S Y=$P(IBCDFND,"^",20),C=$P(^DD(2.312,.2,0),"^",2) D Y^DIQ
  D SET^IBCNSP(START+5,OFFSET,"Coord.  Benefits: "_Y)
@@ -25,7 +25,8 @@
 VER ; -- Entered/Verfied Region
  N OFFSET,START
- S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
- S IB1ST("VERIFY")=START
+ S START=41+$G(IBLCNT),OFFSET=2
+ I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET,"  ")
  D SET^IBCNSP(START,OFFSET," User Information ",IORVON,IORVOFF)
+ I IBCDFND1="" D SET^IBCNSP(START+1,OFFSET,"No User Information") G VERQ
  D SET^IBCNSP(START+1,OFFSET,"      Entered By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",2),0)),"^",1),1,20))
  D SET^IBCNSP(START+2,OFFSET,"      Entered On: "_$$DAT1^IBOUTL(+IBCDFND1))
@@ -34,61 +35,21 @@
  D SET^IBCNSP(START+5,OFFSET," Last Updated By: "_$E($P($G(^VA(200,+$P(IBCDFND1,"^",6),0)),"^",1),1,20))
  D SET^IBCNSP(START+6,OFFSET," Last Updated On: "_$$DAT1^IBOUTL(+$P(IBCDFND1,"^",5)))
- D SET^IBCNSP(START+7,2," ")   ; 2 blank lines to end section
- D SET^IBCNSP(START+8,2," ")
 VERQ Q
- ;
-ID ; Subscriber and patient primary and secondary ID's and qualifiers
- NEW START,OFFSET,IBL,G,PCE,QUAL,QUAL1
- S G=IBCDFND5
- S (START,IBL)=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
- S IB1ST("ID")=START
- D SET^IBCNSP(START,OFFSET," Insurance Company ID Numbers (use Subscriber Update Action) ",IORVON,IORVOFF)
- S IBL=IBL+1
- D SET^IBCNSP(IBL,OFFSET,"  Subscriber Primary ID: "_$P(IBCDFND,U,2))
- ;
- F PCE=3,5,7 D            ; subscriber secondary IDs
- . I $P(G,U,PCE)="" Q     ; no secondary ID#
- . S QUAL=$P(G,U,PCE-1)   ; internal qualifier code
- . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown")
- . S IBL=IBL+1
- . D SET^IBCNSP(IBL,OFFSET,"Subscriber Secondary ID: "_$P(G,U,PCE))
- . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")")
- . Q
- ;
- ; patient=subscriber so skip over patient ID# display
- I +$P(IBCDFND,U,16)=1 G ID1
- ;
- S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")   ; blank line
- S IBL=IBL+1
- D SET^IBCNSP(IBL,OFFSET,"     Patient Primary ID: "_$P(G,U,1))
- ;
- F PCE=9,11,13 D          ; patient secondary IDs
- . I $P(G,U,PCE)="" Q     ; no secondary ID#
- . S QUAL=$P(G,U,PCE-1)   ; internal qualifier code
- . S QUAL1=$S(QUAL="23":"Client#",QUAL="IG":"Ins. Policy#",QUAL="SY":"SSN",1:"Unknown")
- . S IBL=IBL+1
- . D SET^IBCNSP(IBL,OFFSET,"   Patient Secondary ID: "_$P(G,U,PCE))
- . D SET^IBCNSP(IBL,52,"ID Qual: "_QUAL_" ("_QUAL1_")")
- . Q
- ;
-ID1 ; end of section - 2 blank lines
- S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")
- S IBL=IBL+1 D SET^IBCNSP(IBL,2," ")
-IDQ ;
- Q
  ;
 RIDER ; -- Personal policy riders
  N OFFSET,START,IBI,IBL,IBPR,IBPRD
- S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2,IBL=0
+ S START=53+$G(IBLCNT),OFFSET=2,IBL=0
+ I '$D(@VALMAR@(START-1)) D SET^IBCNSP(START-1,OFFSET,"  ")
  D SET^IBCNSP(START,OFFSET," Personal Riders ",IORVON,IORVOFF)
  S IBI="" F  S IBI=$O(^IBA(355.7,"APP",DFN,IBCDFN,IBI)) Q:'IBI  S IBPR=$O(^(IBI,0)),IBPRD=+$G(^IBA(355.7,IBPR,0)),IBL=IBL+1 D
- . D SET^IBCNSP(START+IBL,OFFSET,"   Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD))
- . Q
- S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ")
- S IBL=IBL+1 D SET^IBCNSP(START+IBL,OFFSET," ")
+ .D SET^IBCNSP(START+IBL,OFFSET,"   Rider #"_IBL_": "_$$EXPAND^IBTRE(355.7,.01,IBPRD))
+ S IBLCNT=$G(IBLCNT)+IBL
  Q
  ;
 AI ; -- Add ins. verification entry
  ;    called from ai^ibcnsp1
+ ;N X,Y,I,J,DA,DR,DIC,DIE,DR,DD,DO,VA,VAIN,VAERR,IBQUIT,IBXIFN,IBTRN,DUOUT,IBX,IBQUIT,DTOUT
+ ;Q:'$G(DFN)
+ ;Q:'$G(IBCDFN)  S IBQUIT=0
  ;
  ; -- see if current inpatient
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP1.m	(revision 636)
@@ -1,6 +1,5 @@
-IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ;22-OCT-92
- ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361,371,377**;21-MAR-94;Build 23
+IBCNSP1 ;ALB/AAS - INSURANCE MANAGEMENT - policy actions ; 22-OCT-92
+ ;;2.0;INTEGRATED BILLING;**6,28,40,43,52,85,103,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;;ICR#5002 for read of ^DIE input template data
  ;
 % G EN^IBCNSP
@@ -80,5 +79,5 @@
  S DR="8;3;1.09//;3.04"
  D ^DIE K DIC,DIE,DA,DR
- D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),UPDCLM(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
+ D COMPPT^IBCNSP3(DFN,IBCDFN) I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),AFTER^IBCNSEVT,^IBCNSEVT,BLD^IBCNSP
  L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
 EDQ S VALMBCK="R" Q
@@ -98,7 +97,7 @@
  D VARS^IBCNSP3
  L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G SUQ
- ;
- D EDIT(DFN,IBCDFN)   ; IB*371 - edit pat ins 2.312 subfile fields
- ;
+ S DR="6;S IBAD=X;K X I '$$VET^IBCNSU1() S Y=""@10"";17///^S X=$P(^DPT(DFN,0),U);16///^S X=""01"""
+ S DR=DR_";S Y=""@20"";@10;17;16//^S X=$S(IBAD=""s"":""02"",1:"""");@20;1;.2;4.01;4.02;3.01;3.12;3.02;3.03;3.05:3.11"
+ D ^DIE K DIC,DIE,DA,DR
  D COMPPT^IBCNSP3(DFN,IBCDFN)
  I IBDIF D UPDATPT^IBCNSP3(DFN,IBCDFN),BLD^IBCNSP
@@ -119,125 +118,2 @@
  D AI^IBCNSP02
  Q
- ;
-PIDEF(IBREL,FLD,IBDFN,SPDEF) ; Function to return patient file defaults
- ; Called from input template IBCN PATIENT INSURANCE
- ; IBREL = value from 2.312,4.03 field (PT. RELATIONSHIP - HIPAA)
- ;   FLD = field# in file 2.312
- ; IBDFN = patient ien to file 2
- ; SPDEF = spouse default flag =1 if this field should be defaulted
- ;         when the spouse is the policy holder
- ;
- ; The purpose is to provide a default value for the field when the
- ; patient and the ins. subscriber are the same.
- ;
- NEW VAL
- S VAL=""
- I +$G(IBREL)'=1,+$G(IBREL)'=18 G PIDEFX     ; patient not the insured or spouse, get out
- I +$G(IBREL)=1,'$G(SPDEF) G PIDEFX          ; not a field for spouse default
- I '$G(FLD) G PIDEFX                         ; no field# passed in
- I '$G(IBDFN) G PIDEFX                       ; no patient passed in
- ;
- ; Build the patient demographics area
- I '$D(^UTILITY("VADM",$J)) D
- . N VAHOW,DFN,VADM
- . S VAHOW=2,DFN=IBDFN D DEM^VADPT
- . Q
- ;
- ; Build the patient address area
- I '$D(^UTILITY("VAPA",$J)) D
- . N VAHOW,DFN,VAPA
- . S VAHOW=2,DFN=IBDFN,VAPA("P")="" D ADD^VADPT
- . Q
- ;
- I FLD=17 S VAL=$P($G(^UTILITY("VADM",$J,1)),U,1) G PIDEFX                          ; Name
- I FLD=3.01 S VAL=$$FMTE^XLFDT($P($G(^UTILITY("VADM",$J,3)),U,1),"5Z") G PIDEFX     ; Date of Birth
- I FLD=3.02 S VAL=$$EXTERNAL^DILFD(2,.325,,$P($G(^DPT(IBDFN,.32)),U,5)) G PIDEFX    ; Branch
- I FLD=3.05 S VAL=$P($G(^UTILITY("VADM",$J,2)),U,2) G PIDEFX                        ; SSN
- I FLD=3.06 S VAL=$P($G(^UTILITY("VAPA",$J,1)),U,1) G PIDEFX                        ; Street Address 1
- I FLD=3.07 S VAL=$P($G(^UTILITY("VAPA",$J,2)),U,1) G PIDEFX                        ; Street Address 2
- I FLD=3.08 S VAL=$P($G(^UTILITY("VAPA",$J,4)),U,1) G PIDEFX                        ; City
- I FLD=3.09 S VAL=$P($G(^UTILITY("VAPA",$J,5)),U,2) G PIDEFX                        ; State
- I FLD=3.1 S VAL=$P($G(^UTILITY("VAPA",$J,11)),U,2) G PIDEFX                        ; Zipcode
- I FLD=3.11 S VAL=$P($G(^UTILITY("VAPA",$J,8)),U,1) G PIDEFX                        ; Phone#
- I FLD=3.12 S VAL=$P($G(^UTILITY("VADM",$J,5)),U,2) G PIDEFX                        ; Sex
-PIDEFX ;
- Q VAL
- ;
-ASK(QUES,DEFLT) ; Function to ask Yes/No Question
- ; Returns 1 (yes), 0 (no, up-arrow, or timeout)
- NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
- S DIR(0)="Y",DIR("A")=$G(QUES)
- S DIR("B")=$S($G(DEFLT):"Yes",1:"No")
- W ! D ^DIR W:Y !
- I $D(DIRUT) S Y=0
-ASKX ;
- Q Y
- ;
-EDIT(IBDFN,IBCDFN,IBQUIT) ; Main call to edit data in 2.312 pat ins subfile
- ;  IBDFN - patient DFN
- ; IBCDFN - ien for patient insurance policy in subfile 2.312
- ; IBQUIT - Output variable.  Pass by reference.  Will be set to 1 if
- ;          the user entered an up-arrow, timed-out, or deleted the
- ;          2.312 subfile entry by entering "@" at the .01 field
- ; 
- NEW DA,DR,DIE,IBZ,IBY,X,Y,DTOUT
- NEW IDS,SUB,PAT,PCE,SUB1,PAT1
- S DA(1)=+$G(IBDFN)    ; patient IEN
- S DA=+$G(IBCDFN)      ; patient insurance IEN
- I 'DA!'DA(1) G EDITX
- S DIE="^DPT("_IBDFN_",.312,"
- ;
- ; Find the input template IEN for the [IBCN PATIENT INSURANCE] template
- S IBY=+$$FIND1^DIC(.402,,"X","IBCN PATIENT INSURANCE")
- I 'IBY G EDITX
- ;
- ; Build the DR array/string - ICR# 5002
- M DR(1)=^DIE(IBY,"DR",2)
- S DR=$G(DR(1,2.312))
- I DR="" G EDITX
- ;
- S $P(^DIE(IBY,0),U,7)=DT   ; see TEM+2^DIE  ICR# 5002
- ;
- D ^DIE     ; edit subfile data
- ;
- ; If the user entered an up-arrow, or timed-out, or deleted the entry,
- ; then set the output variable IBQUIT
- I $D(Y)!$D(DTOUT)!'$D(DA) S IBQUIT=1
- ;
- F IBZ="VADM","VAPA" K ^UTILITY(IBZ,$J)    ; cleanup scratch global
- ;
- D UPDCLM(IBDFN,IBCDFN)      ; update editable claims
- ;
- ; Cleanup any problems in the secondary ID area
- S IDS=$G(^DPT(IBDFN,.312,IBCDFN,5))           ; whole 5 node
- S (SUB,PAT)=""
- F PCE=3:1:8 S $P(SUB,U,PCE)=$P(IDS,U,PCE-1)   ; subscriber sec ID/qual
- F PCE=3:1:8 S $P(PAT,U,PCE)=$P(IDS,U,PCE+5)   ; patient sec ID/qual
- ; SUB and PAT are 8-piece strings with pieces 1 and 2 being nil
- S SUB1=$$SCRUB^IBCEF21(SUB)                   ; scrub 8-piece string
- S PAT1=$$SCRUB^IBCEF21(PAT)                   ; scrub 8-piece string
- I SUB'=SUB1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,2,7)=$P(SUB1,U,3,8)
- I PAT'=PAT1 S $P(^DPT(IBDFN,.312,IBCDFN,5),U,8,13)=$P(PAT1,U,3,8)
- ;
-EDITX ;
- Q
- ;
-UPDCLM(IBDFN,IBCDFN) ; Update the Insurance nodes of claims that are still editable
- NEW IBIFN
- S IBIFN=0 F  S IBIFN=$O(^DGCR(399,"C",IBDFN,IBIFN)) Q:'IBIFN  D UPDCLM^IBCNSP2(IBIFN,IBDFN,IBCDFN)
- ;
-UPDCLMX ;
- Q
- ;
-PRELCNV(CODE,FLG) ; conversion between X12, NCPDP and VistA pt. relationship codes
- ; CODE - code for pt. relationship to convert
- ; FLG - 0 for X12 -> VistA conversion, 1 for VistA -> X12 conversion, 2 - for VistA -> NCPDP conversion
- ; returns converted code for pt. relationship, or null if no match found
- N I,RES,VSTR,X12STR
- S VSTR="01^02^03^08^11^15^32^33^34^35^36"
- S X12STR="18^01^19^20^39^41^32^33^29^53^G8"
- S RES=""
- I FLG=0 F I=1:1:11 S:$P(X12STR,U,I)=CODE RES=$P(VSTR,U,I) Q:RES'=""
- I FLG=1 F I=1:1:11 S:$P(VSTR,U,I)=CODE RES=$P(X12STR,U,I) Q:RES'=""
- I FLG=2,+CODE>0 S RES=$S(+CODE>3:"04",1:CODE)
- Q RES
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP2.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCNSP2 ;ALB/AAS - PATIENT INSURANCE INTERFACE FOR REGISTRATION ;21-JUNE-93
- ;;2.0;INTEGRATED BILLING;**6,28,75,82,155,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**6,28,75,82,155**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 % ;
@@ -22,4 +22,13 @@
  ;
  I '$$ASKCOVD(DFN,.IBCOV,.IBCOVP) S IBQUIT=1 G REGQ
+ ; -- of covered by ins but none currently active so indicate
+ ;S IBCOV=$P($G(^DPT(DFN,.31)),"^",11)
+ ;I IBCOV="Y",'$$INSURED^IBCNS1(DFN) W !!,"Covered By Health Insurance indicates 'YES' but none currently Active.",!,"Please Review!",!!
+ ;
+ ;; -- ask if covered by insuracnce
+ ;S DIE="^DPT(",DR=".3192",DA=DFN D ^DIE K DIC,DIE,DA,DR
+ ;S IBCOVP=$P($G(^DPT(DFN,.31)),"^",11)
+ ;I $D(Y)!($D(DTOUT)) S IBQUIT=1 G REGQ
+ ;I $P($G(^DPT(DFN,.31)),"^",11)'="Y",'$$INSURED^IBCNS1(DFN) S IBQUIT=1 G REGQ
  ;
 R1 S (IBNEW,IBNEWP,IBQUIT)=0
@@ -52,5 +61,5 @@
  ; -- edit patient ins. data
  S IBREG=1 G:$G(IBQUIT) REGQ
- D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN),UPDCLM(+$G(IBIFN),DFN,IBCDFN)
+ D PAT^IBCNSEH,PATPOL^IBCNSM32(IBCDFN)
  ;
  ; -- edit policy specific data if new or have key
@@ -75,4 +84,5 @@
  ;
 FEE ; -- fee entry point to add patient insurance.
+ ;N IBFEE S IBFEE=1 D REG
  D FEE^IBCNBME(DFN)
  Q
@@ -87,21 +97,4 @@
  I 'IBMCR,$$WNRBILL^IBEFUNC(IBIFN) S DGRVRCAL=1
  K IBCNRTN
- Q
- ;
-UPDCLM(IBIFN,DFN,IBCDFN) ; Update the claim's insurance nodes when edits are made
- ;   to the patient insurance file.
- ;  This procedure is called when a claim is being edited from IB billing
- ;  screen#3 and also when the patient insurance is being edited directly.
- ;
- I '$G(IBIFN)!'$G(DFN)!'$G(IBCDFN) Q         ; missing something
- I $P($G(^DGCR(399,IBIFN,0)),U,2)'=DFN Q     ; mismatch of claim and DFN
- I $P($G(^DGCR(399,IBIFN,0)),U,13)'=1 Q      ; claim not editable
- I '$D(^DPT(DFN,.312,IBCDFN,0)) Q            ; missing pat ins data
- NEW X,Z,NODE
- S X=IBCDFN
- F Z=1:1:3 I $P($G(^DGCR(399,IBIFN,"M")),U,11+Z)=IBCDFN D  Q
- . S NODE="I"_Z
- . D IX^IBCNS2(IBIFN,NODE)
- . Q
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSP3.m	(revision 636)
@@ -1,5 +1,5 @@
-IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ;06-JUL-93
- ;;2.0;INTEGRATED BILLING;**28,52,85,251,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ; 06-JUL-93
+ ;;2.0;INTEGRATED BILLING;**28,52,85,251**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 % G ^IBCNSM4
@@ -12,5 +12,4 @@
  S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3))
  S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4))
- S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)=$G(^DPT(DFN,.312,+DA,5))
  Q
  ;
@@ -22,5 +21,4 @@
  I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ
  I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ
- I $G(^DPT(DFN,.312,+DA,5))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)) S IBDIF=1 G COMPPTQ
  ;
 COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11))
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU.m	(revision 636)
@@ -1,5 +1,5 @@
-IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
- ;;2.0;INTEGRATED BILLING;**28,103,371**; 21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
+ ;;2.0;INTEGRATED BILLING;**28,103**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file
@@ -186,23 +186,2 @@
  ;
 DELPQ Q X
- ;
-DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated
- ; DATA - Value being compared
- ; FLD1 - First field to check against
- ; FLD2 - Second field to check against (OPTIONAL)
- ;
- ; Returns 1 if this field is a duplicate of another field.
- ;
- N Z1,Z2
- Q:$G(DATA)="" 0  ; should not happen because this is invoked as an input transform
- Q:'$G(IBCNS) 1  ; stop from editing through fileman
- S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA)
- S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I")
- S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1)
- S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I")
- S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2)
- I DATA=Z1 D CLEAN^DILF Q 1
- I DATA=Z2 D CLEAN^DILF Q 1
- D CLEAN^DILF
- Q 0
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m	(revision 636)
@@ -1,5 +1,5 @@
-IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
- ;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
+ ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 RCHK(X) ; -- Input transform for different revenue codes in file 36
@@ -70,5 +70,4 @@
  ;
  N IBY,IB0 S IBY=0
- G VETQ    ; IB*2*371 - Allow edits to the patient name in all cases
  S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
  I $P(IB0,"^",6)'="v" G VETQ
@@ -95,4 +94,8 @@
  S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
  ;
+ ; - if "SS" is entered, and the policy belongs to the patient,
+ ;   convert that string to the patient's SSN
+ I R=1,X="SS" W "  ",L S X=L
+ ;
  K:$L(X)>20!($L(X)<3) X
  Q
@@ -113,43 +116,2 @@
  S:IBY="" IBY=-1
 HICNQ Q IBY
- ;
-CHKQUAL(DFN,IEN,QUAL,PC1,PC2) ; check for duplicate qualifiers for patient
- ; and subscriber secondary ID's.  All parameters required.
- ;
- ;   DFN - internal patient#
- ;   IEN - ien of 2.312 subfile
- ;  QUAL - passed in response of the user (this is what is being 
- ;         checked to see if it is valid)
- ;   PC1 - this is the piece# for one of the other qualifiers
- ;   PC2 - this is the piece# for one of the other qualifiers
- ;
- ; Function returns 1 if the entered qualifier is OK.
- ; Function returns 0 if the entered qualifier is not OK.  It is either
- ;                    a duplicate or is otherwise invalid.
- ;
- NEW OK,DATA,INS
- S OK=1
- I $G(QUAL)="" G CHKQUALX
- S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5))
- I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX   ; duplicate
- I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX   ; duplicate
- ;
- ; prevent the SSN qualifier when Medicare is the payer
- S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0))
- I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX
- ;
-CHKQUALX ;
- Q OK
- ;
-CQ1 ; specific error message#1
- S OK=0
- D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!")
- D EN^DDIOL("",,"!!?5")
- Q
- ;
-CQ2 ; specific error message#2
- S OK=0
- D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!")
- D EN^DDIOL("",,"!!?5")
- Q
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCRBC ;ALB/ARH - RATES: BILL CALCULATION OF CHARGES ; 22-MAY-1996
- ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245,370**;21-MAR-94;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,51,137,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ; Variable DGPTUPDT may be defined on entry/exit for inpt bills so the PTF will only be updated once per session
@@ -42,4 +42,8 @@
  ;
  I '$D(^TMP($J,"IBCRCC")) G END
+ ;
+ D MULTCPT^IBCRBCA1 ; adjust charges for Multiple Surgical Procedure Discount
+ D PSB^IBCRBCA2 ;     adjust charges for Primary/Secondary Bundling
+ D MODADJ^IBCRBCA3 ;  adjust charges for Modifier Adjustment
  ;
  D SORTCI^IBCRBC3 I '$D(^TMP($J,"IBCRCS")) G END
@@ -136,5 +140,4 @@
  ;                        21 procedures associated clinic
  ;                        22 procedures Outpatient Encounter, pointer to #409.68
- ;                        23 list of all the procedures modifiers, separated by ','
  ;
  ;  ^TMP($J,"IBCRCC",X,"CC",x) = comments explaining charge adjustements
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC1.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCRBC1 ;ALB/ARH - RATES: BILL CALCULATION BILLABLE EVENTS ; 22 MAY 96
- ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270,370**;21-MAR-94;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,138,51,148,245,270**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ; For each type of Billable Event, search for items on the bill and calculate the charges
@@ -115,5 +115,5 @@
  ;
  N IBX,IBBLITEM,IBCHGMTH,IBBR,IBBDIV,IBIDRC,IBCPTARR,IBCPT,IBCPTFN,IBEVDT,IBMOD,IBDIV,IBTYPE,IBCMPNT
- N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX,IBMODS I '$G(IBIFN)!'$G(CS) Q
+ N IBPPRV,IBBS,IBCLIN,IBOE,IBSAVE,IBUNIT,IBCPTRX I '$G(IBIFN)!'$G(CS) Q
  ;
  D CPT^IBCRBG1(IBIFN,.IBCPTARR) Q:'IBCPTARR
@@ -131,5 +131,5 @@
  . S IBCPT=0 F  S IBCPT=$O(IBCPTARR(IBCPT)) Q:'IBCPT  D
  .. S IBCPTFN=0 F  S IBCPTFN=$O(IBCPTARR(IBCPT,IBCPTFN)) Q:'IBCPTFN  D
- ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),(IBMOD,IBMODS)=$P(IBX,U,2)
+ ... S IBX=IBCPTARR(IBCPT,IBCPTFN),IBEVDT=$P(IBX,U,1),IBMOD=$P(IBX,U,2)
  ... S IBDIV=$P(IBX,U,3),IBPPRV=$P(IBX,U,4),IBCLIN=$P(IBX,U,5),IBOE=$P(IBX,U,6)
  ... ;
@@ -146,5 +146,5 @@
  ... I +IBMOD S IBMOD=$P($$CPTMOD^IBCRCU1(CS,IBCPT,IBMOD,IBEVDT),",",1) ; check CPT-MODs for billable combination
  ... ;
- ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE_U_IBMODS
+ ... S IBSAVE="1^"_IBCPT_U_IBDIV_U_IBTYPE_U_IBCPTFN_U_IBCMPNT_U_IBBS_U_IBPPRV_U_IBCLIN_U_IBOE
  ... D BITMCHG^IBCRBC2(RS,CS,IBCPT,IBEVDT,IBUNIT,IBMOD,"",IBIDRC,IBSAVE)
  K ^TMP($J,"IBCRC-INDT")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBC2.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCRBC2 ;ALB/ARH - RATES: BILL CALCULATION OF ITEM CHARGE ; 22-MAY-1996
- ;;2.0;INTEGRATED BILLING;**52,106,138,148,245,370**;21-MAR-94;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,106,138,148,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ; Input:  RS     - rate schedule necessary to calculated modified charges
@@ -22,5 +22,4 @@
  ;                  CLINIC - procedures associated clinic
  ;                  IBOE   - Outpatient Encounter, pointer to #408.69
- ;                  MODS   - list of all modifiers define for the procedure, separated by ','
  ;
  ; Total charge is calculated:  X = UNITS * UNIT CHARGE of the item         (per unit charge (un-adjusted))
@@ -35,9 +34,9 @@
 BITMCHG(RS,CS,ITEM,EVDT,UNITS,MOD,INSRC,IDFRC,SAVE) ; get bill charges for a specific item, rate schedule and charge set and date set into temp array
  ;
- N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG
- N IBMCHRG,IBMODS,IBBASE,IBCOM I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
+ N IBCS0,IBDRVCD,IBBS,IBCHGARR,IBI,IBCNT,IBLN,IBCI,IBRVCD,IBPPRV,IBCHRG,IBTCHRG,IBRCHRG,IBPCHRG,IBACHRG,IBBASE,IBCOM
+ I '$G(ITEM)!'$G(CS)!'$G(UNITS) Q
  ;
  S RS=$G(RS),EVDT=$S(+$G(EVDT):+EVDT\1,1:DT),MOD=$G(MOD),INSRC=$G(INSRC),IDFRC=$G(IDFRC),SAVE=$G(SAVE)
- S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8),IBMODS=$P(SAVE,U,11)
+ S IBCS0=$G(^IBE(363.1,+CS,0)),IBDRVCD=$P(IBCS0,U,5),IBPPRV=$P(SAVE,U,8)
  S IBBS=+ITEM I $P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)'=1 S IBBS=$P(SAVE,U,7) I 'IBBS S IBBS=$P(IBCS0,U,6)
  I 'IBBS Q
@@ -55,6 +54,5 @@
  . S IBCHRG=IBCHRG+IBBASE
  . S IBPCHRG=IBCHRG I +IBPPRV S IBPCHRG=$$PRVCHG^IBCRCC(CS,IBCHRG,IBPPRV,EVDT,ITEM)
- . S IBMCHRG=+IBPCHRG I +IBMODS S IBMCHRG=$$MODCHG^IBCRCC(CS,IBPCHRG,IBMODS)
- . S (IBCHRG,IBTCHRG)=+IBMCHRG
+ . S (IBCHRG,IBTCHRG)=+IBPCHRG
  . S IBACHRG=IBTCHRG I +RS,+IBTCHRG S IBRCHRG=$$RATECHG^IBCRCC(RS,IBTCHRG,EVDT),IBACHRG=+IBRCHRG
  . ;
@@ -64,5 +62,4 @@
  . I (UNITS>1)!(+IBBASE) S IBCOM=$$COMMUB(CS,UNITS,IBBASE) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
  . I $P(IBPCHRG,U,2)'="" S IBCOM=$P(IBPCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
- . I $P(IBMCHRG,U,2)'="" S IBCOM=$P(IBMCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
  . I $P(IBRCHRG,U,2)'="" S IBCOM=$P(IBRCHRG,U,2) I IBCOM'="" D COMMENT(IBCNT,IBCOM)
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBG.m	(revision 636)
@@ -1,10 +1,10 @@
 IBCRBG ;ALB/ARH - RATES: BILL SOURCE EVENTS (INPT) ; 21 MAY 96
- ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245,382,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,51,142,159,210,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 INPTPTF(IBIFN,CS) ; search PTF record for billable bedsections, transfer DRGs, and length of stay 
  ; - screens out days for pass, leave and SC treatment
  ; - adds charges for only one BS if the ins company does not allow multiple bedsections per bill (36,.06)
- ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
+ ; Output:  ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
  ;
  N IB0,DFN,PTF,IBU,IBBDT,IBEDT,IBTF,IBADM,IBX,IBINSMBS
@@ -24,5 +24,4 @@
  D PTF(PTF) ; get movements and bedsections
  D PTFDV(PTF) ; reset movements and bedsections for ward/division
- D PTFFY(PTF,IBBDT,IBEDT) ; reset movements for FY DRG change
  ;
  D BSLOS(IBBDT,IBEDT,IBTF,IBADM,IBINSMBS) ; calculate days in bedsections within timeframe of the bill
@@ -35,5 +34,5 @@
 PTF(PTF) ; find all movements in PTF for the admission by date and billing bedsection (501 movement)
  ; the movement date is the date the patient left the bedsection
- ; Output: ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BED ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY ^ MOVE #
+ ; Output:  ^TMP($J,"IBCRC-PTF", MOVE DT/TM)=MOVE DT/TM ^ BILL BEDSECTION ^ SC FLAG ^ TRANSFER DRG ^ ^ SPECIALTY
  ;
  N IBMOVE,IBMVLN,IBBILLBS,IBENDDT,IBMSC,IBMDRG S PTF=+$G(PTF)
@@ -44,5 +43,5 @@
  . S IBMSC="" I +$P(IBMVLN,U,18)=1 S IBMSC=1 ;                          sc movement
  . S IBMDRG=$$MVDRG(PTF,IBMOVE) ;                                       movement DRG
- . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)_U_IBMOVE
+ . S ^TMP($J,"IBCRC-PTF",IBENDDT)=IBENDDT_U_IBBILLBS_U_IBMSC_U_IBMDRG_U_U_+$P(IBMVLN,U,2)
  Q
  ;
@@ -58,6 +57,6 @@
  ; the movement date is the date the patient left the bedsection, so admission date is not in PTF array
  ;
- ; Input:  ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
- ; Output: ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIV ^ SPECIALTY ^ MOVE #
+ ; Input:   ^TMP($J,"IBCRC-PTF", MOVE DT/TM) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
+ ; Output:  ^TMP($J,"IBCRC-INDT", BILLABLE DATE) = MOVE DT/TM ^ BILL BS ^ SC FLAG ^ DRG ^ DIVISION ^ SPECIALTY
  ;
  N IBSBDT,IBSEDT,IBS,IBLASTDT,IBX
@@ -97,6 +96,6 @@
 PTFDV(PTF) ; find all ward/location transfers in PTF for the patient to determine the site/division the patient was in
  ; the division of the ward will be added to the PTF bedsection movements
- ; Input:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
- ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ spec ^ move#
+ ; Input:   ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^^ specialty
+ ; Output:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ WARD DIV ^ specialty
  ;          ^TMP($J,"IBCRC-DIV", TRANSFER DATE/TIME) = WARD DIVISION
  N IBTRNSF,IBTRLN,IBENDDT,IBTRDV,IBMVDT,IBTRDT
@@ -124,21 +123,5 @@
  Q
  ;
-PTFFY(PTF,BEGDT,ENDDT) ; add movement for FY (10/1) if date range covers FY and DRG changes
- ; the DRG may change on FY so check and if necessary add movement for pre-FY with old DRG
- ; Input:  ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ move drg ^ ^ specialty ^ move #
- ; Output: ^TMP($J,"IBCRC-PTF", move dt/tm) = move dt/tm ^ bill bs ^ sc flag ^ MOVE DRG ^ ward div ^ spec ^ move#
- N IBBEGDT,IBENDDT,IBYRB,IBYRE,IBYR,IBFY,IBMVLN,IBMVDRG,IBMOVE,IBFYDRG Q:'$G(PTF)
- Q:'$G(BEGDT)  S IBFY=$E(BEGDT,1,3)_"1001"
- ;
- S IBBEGDT=BEGDT,IBENDDT=BEGDT\1 F  S IBENDDT=$O(^TMP($J,"IBCRC-PTF",IBENDDT)) Q:'IBENDDT  D  S IBBEGDT=IBENDDT
- . S IBYRB=$E(IBBEGDT,1,3),IBYRE=$E(IBENDDT,1,3) I (IBYRE-IBYRB)>10 Q
- . F IBYR=IBYRB:1:IBYRE S IBFY=IBYR_"1001" I IBBEGDT<IBFY,IBENDDT>IBFY D
- .. S IBMVLN=$G(^TMP($J,"IBCRC-PTF",IBENDDT)),IBMVDRG=$P(IBMVLN,U,4),IBMOVE=$P(IBMVLN,U,7)
- .. S IBFYDRG=$$MVDRG(PTF,IBMOVE,IBYR_"0930")
- .. I IBMVDRG'=IBFYDRG S $P(IBMVLN,U,4)=IBFYDRG S ^TMP($J,"IBCRC-PTF",IBFY)=IBMVLN
- Q
- ;
-MVDRG(PTF,M,CDATE) ; Return the DRG for a specific PTF Movememt (M=move ifn)
- ; CDATE is optional, used if need to calculate DRG for some day within the move, not at the end date
+MVDRG(PTF,M) ; Return the DRG for a specific PTF Movememt (M=move ifn)
  N DPT0,PTF0,PTFM0,PTF70,IBBEG,IBEND,IBDSST,IBDX,IBPRC0,IBPRC,IBDRG,IBI,IBJ,IBP
  N SEX,AGE,ICDDX,ICDPRC,ICDEXP,ICDDMS,ICDTRS,ICDDRG,ICDMDC,ICDRTC,ICDDATE
@@ -175,5 +158,5 @@
  .. F IBI=5:1:9 S IBPRC=$P(IBPRC0,U,IBI) I +IBPRC,($$ICD0^IBACSV(+IBPRC)'="") S IBJ=IBJ+1,ICDPRC(IBJ)=+IBPRC
  ;
- S ICDDATE=$S(+$G(CDATE):CDATE,+$P(PTFM0,U,10):+$P(PTFM0,U,10),1:DT) ; date for the DRG Grouper versioning
+ S ICDDATE=$P(PTFM0,U,10) ; use the movement date for the DRG Grouper versioning
  D ^ICDDRG S IBDRG=$G(ICDDRG)
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH1.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCRBH1 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CHARGES ; 10-OCT-1998
- ;;2.0;INTEGRATED BILLING;**106,245,370**;21-MAR-94;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**106,245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 DISPCHG(IBIFN) ; display a bills items and their charges, display only, does not change the charges on the bill
@@ -36,4 +36,10 @@
  .. I IBBEVNT["PROSTHETICS" D PI^IBCRBC1(IBIFN,IBRS,IBCS)
  .. I IBBEVNT["PROCEDURE" D CPT^IBCRBC1(IBIFN,IBRS,IBCS)
+ ;
+ I '$D(^TMP($J,"IBCRCC")) G END
+ ;
+ D MULTCPT^IBCRBCA1
+ D PSB^IBCRBCA2
+ D MODADJ^IBCRBCA3
  ;
 END Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRCC.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCRCC ;ALB/ARH - RATES: CALCULATION OF ITEM CHARGE ;22-MAY-1996
- ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347,370**;21-MAR-94;Build 5
+ ;;2.0;INTEGRATED BILLING;**52,80,106,138,245,223,309,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -91,23 +91,4 @@
  Q IBX_IBPDTY
  ;
-MODCHG(CS,CHG,MODS) ; return adjusted amount due to RC modifier adjustment
- ; straight adjustment for RC Physician charges by modifier, if no modifier adjustment returns original amount
- ; Input:  Charge Set, Procedure Charge, Modifiers - list with modifier IEN's separated by ','
- ; Output: discounted amount ^ comment (if discounted) ^ percent discount
- ;
- N IBCS0,IBBR0,IBMOD,IBMODS,IBMODE,IBDSCNT,IBPDTY,IBI,IBX,IBY
- S CHG=+$G(CHG),MODS=$G(MODS),(IBBR0,IBPDTY,IBMODS)="",IBDSCNT=1,IBX=+CHG
- I +$G(CS) S IBCS0=$G(^IBE(363.1,+CS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
- I $P(IBBR0,U,1)'["RC PHYSICIAN" S MODS="" ; professional charge only
- I $P(IBBR0,U,4)'=2 S MODS="" ; CPT item only
- I 'CHG S MODS=""
- ;
- I +MODS F IBI=1:1 S IBMOD=$P(MODS,",",IBI) Q:'IBMOD  S IBY=0 D
- . I IBMOD=3 S IBMODE=22,IBY=1.2,IBX=IBX*IBY ; modifier 22 at 120% adjustment
- . I IBMOD=10 S IBMODE=50,IBY=1.54,IBX=IBX*IBY ; modifier 50 at 154% adjustment
- . I +IBY S IBMODS=IBMODS_$S(IBMODS="":"",1:",")_IBMODE,IBDSCNT=IBDSCNT*IBY ; allow for multiple discounts
- I IBMODS'="" S IBPDTY=U_"Modifier "_IBMODS_" Adjustment "_(IBDSCNT*100)_"% of "_$J(CHG,0,2)_U_+IBDSCNT
- Q IBX_IBPDTY
- ;
 HRUNIT(HRS) ; returns Hour Units based on the Hours passed in
  ; Hour Units are the hours rounded to the nearest whole hour (less than 30 minutes is 0 units)
@@ -121,5 +102,5 @@
  ;
 MNUNIT(MNS) ; return Minute Units based on the Minutes passed in
- ; Minute Units are 15 minute intervals, rounded up after any minutes
- N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:+(MNS#15) IBX=IBX+1 I 'IBX S IBX=1
+ ; Minute Units are 15 minute intervals, rounded down for less than 5 minutes
+ N IBX S IBX=0 I +$G(MNS) S IBX=(MNS\15) S:(MNS#15)>4 IBX=IBX+1 I 'IBX S IBX=1
  Q IBX
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBRV.m	(revision 636)
@@ -1,26 +1,18 @@
 IBCRHBRV ;ALB/ARH - RATES: UPLOAD (RC) VERSION FUNCTIONS ; 14-FEB-01
- ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365,382,390**;21-MAR-94;Build 2
+ ;;2.0;INTEGRATED BILLING;**148,169,245,270,285,298,325,334,355,360,365**;21-MAR-94;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
- ; RC functions related to Version.  Update VLIST with new versions.  Update FTYPE if new types of files.
+ ; RC functions related to Version, most have to be updated when a new version is to be exported
  ;
 SELVERS() ; get version to upload from user
- N DIR,DIRUT,DTOUT,DUOUT,IBVLIST,IBQUIT,IBVERS,IBI,IBJ,IBX,X,Y
- ;
- S IBVLIST=$$VERSTR(),IBQUIT=0,IBVERS=0
- ;
- W !!,"Select the version of Reasonable Charges to upload."
- S DIR("?",1)="Enter the code from the list corresponding to the version of Reasonable Charges"
- S DIR("?",2)="to upload.  There are no version 1.3, 2.2, or 2.10 (ten) RC charges." S DIR("?",3)=" "
- S DIR("?",4)="Versions: "_IBVLIST S DIR("?",5)=" " S DIR("?")="Enter version number to upload."
- ;
- F IBI=1:1 D  I +IBQUIT Q
- . W !!,?5,"Select one of the following:",!
- . F IBJ=1:1 S IBX=$P(IBVLIST,",",IBJ) Q:'IBX  W !,?10,IBX,?20,"Reasonable Charges version ",IBX
- . ;
- . W ! S DIR("A")="Enter Version" S DIR(0)="FO^1:5" D ^DIR I $D(DIRUT) S IBQUIT=1
- . I Y>0,(","_IBVLIST_",")[(","_Y_",") S IBVERS=Y,IBQUIT=1 W "  Reasonable Charges version ",IBVERS
- ;
- Q IBVERS
+ N DIR,DIRUT,DTOUT,DUOUT,X,Y,IB,IBV,IBVP,IBX
+ S IBV="1.0^1.1^1.2^1.4^2.0^2.1^2.3^2.4^2.5^2.6^2.7^2.8^2.9" ; List of valid version numbers
+ S IBX=0
+ W !!,"Select the version of Reasonable Charges to upload.",!
+ S DIR("?")="Enter a code from the list corresponding to the version of Reasonable Charges to upload.  There was no version 1.3 nor 2.2 of Reasonable Charges."
+ S DIR(0)="SO^"
+ F IB=1:1:$L(IBV,U) S IBVP=$P(IBV,U,IB),DIR(0)=DIR(0)_+IBVP_":Reasonable Charges version "_IBVP_";"
+ D ^DIR K DIR S:$L(Y)=1 Y=Y_".0" S IBX=+$S(IBV[Y:Y,1:0)
+ Q IBX
  ;
 VERSION() ; return currently loaded version of RC files (1, 1.1, ...)
@@ -29,27 +21,26 @@
  ;
 VERSDT(VERS) ; return Effective Date of a version of RC files, either version passed in or currently loaded version
- N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION
- I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBX=$P(LINE,U,3)
+ N IBX S:'$G(VERS) VERS=$$VERSION
+ S IBX=$S(VERS=1:2990901,VERS=1.1:3001102,VERS=1.2:3010508,VERS=1.4:3030429,VERS=2:3031219,VERS=2.1:3040415,VERS=2.3:3050101,VERS=2.4:3050411,VERS=2.5:3051001,VERS=2.6:3060101,VERS=2.7:3060825,VERS=2.8:3061001,VERS=2.9:3070101,1:"")
  Q IBX
  ;
 VERSEDT(VERS) ; return Inactive Date of a version of RC files, either version passed in or currently loaded version
- N IBI,LINE,IBX S IBX="" S VERS=+$G(VERS) I 'VERS S VERS=$$VERSION
- I +VERS F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBX=$P(LINE,U,4)
+ N IBX S:'$G(VERS) VERS=$$VERSION
+ S IBX=$S(VERS=1:3001101,VERS=1.1:3010507,VERS=1.2:3030428,VERS=1.4:3031218,VERS=2:3040414,VERS=2.1:3041231,VERS=2.3:3050410,VERS=2.4:3050930,VERS=2.5:3051231,VERS=2.6:3060824,VERS=2.7:3060930,VERS=2.8:3061231,1:"")
  Q IBX
  ;
-VERSALL() ; return all RC versions and corresponding effective date 'VERS;EFFDT^VERS;EFFDT^...'
- N IBI,LINE,IBX,IBC S IBX="",IBC=""
- F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,3),IBC=U
+VERSALL() ; returns all RC versions and corresponding effective date
+ N IBX S IBX="1;2990901^1.1;3001102^1.2;3010508^1.4;3030429^2;3031219^2.1;3040415^2.3;3050101^2.4;3050411^2.5;3051001^2.6;3060101^2.7;3060825^2.8;3061001^2.9;3070101"
  Q IBX
  ;
-VERSEND() ; return all RC versions and corresponding inactive date 'VERS;INACTIVE DT^VERS;INACTIVE DT^...'
- N IBI,LINE,IBX,IBC S IBX="",IBC=""
- F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I $P(LINE,U,4) S IBX=IBX_IBC_+LINE_";"_$P(LINE,U,4),IBC=U
+VERSEND() ; returns all RC versions and corresponding inactive dates
+ N IBX S IBX="1;3001101^1.1;3010507^1.2;3030428^1.4;3031218^2;3040414^2.1;3041231^2.3;3050410^2.4;3050930^2.5;3051231^2.6;3060824^2.7;3060930^2.8;3061231"
  Q IBX
+ ;
  ;
 VERSITE(SITE) ; returns the list of versions loaded for a particular site
  ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
  ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
- N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY,IBC
+ N IBCS,IBXRF,IBITM,IBVERS,IBCSFN,IBI,IBV,IBX,IBY S IBX=""
  S IBVERS=$$VERSALL,IBITM=99201
  ;
@@ -58,7 +49,7 @@
  . S IBCSFN=$O(^IBE(363.1,"B",IBCS,0)) Q:'IBCSFN  S IBXRF="AIVDTS"_IBCSFN
  . F IBI=1:1 S IBV=$P(IBVERS,U,IBI) Q:'IBV  I $O(^IBA(363.2,IBXRF,IBITM,-$P(IBV,";",2),0)) S IBY(+IBV)=""
+ S IBV="" F  S IBV=$O(IBY(IBV)) Q:'IBV  S IBX=IBX_IBV_","
  ;
- S (IBX,IBC)="" F IBI=1:1 S IBV=+$P(IBVERS,U,IBI) Q:'IBV  I $D(IBY(IBV)) S IBX=IBX_IBC_IBV S IBC=","
- ;
+ I $E(IBX,$L(IBX))="," S IBX=$E(IBX,1,$L(IBX)-1)
  Q IBX
  ;
@@ -71,4 +62,5 @@
  ;
 MSGVERS(SITE) ; check if versions are being loaded in the correct order, should be loaded in date order
+ ; displays messages to the user:
  ;   - if loading a version that has already been loaded for the site
  ;   - if loading a version when any future versions have already been loaded for the site
@@ -76,102 +68,114 @@
  ; *** uses 99201 in the RC PHYSICIAN set to check which versions/dates are loaded
  ; *** so 99201 must have a pro charge in all versions, if not it must be replaced with an item that does
- N IBVERS,IBVDTC,IBVERSIN,IBVERSC,IBVERSO,IBI,VERSTR Q:'$G(SITE)
+ N IBVERS,IBVDTC,IBVERSIN,IBVERSO Q:'$G(SITE)
  ;
- S IBVERS=$$VERSION Q:'IBVERS  S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_",",IBVERSC=","_IBVERS_","
+ S IBVERS=$$VERSION Q:'IBVERS  S IBVDTC=$$VERSDT,IBVERSIN=","_$$VERSITE(SITE)_","
  ;
  ; check if loading a version that has already been loaded
- I IBVERSIN[IBVERSC D
+ I IBVERSIN[(","_IBVERS_",") D
  . W !!,?5,"*** It appears version RC v",IBVERS," has already been loaded for this site ***"
  ;
  ; check if loading a version when any future versions have already been loaded
- S VERSTR=","_$$VERSTR()_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions after current version
- F IBI=1:1 S IBVERSO=$P(VERSTR,",",IBI) Q:'IBVERSO  I IBVERSIN[(","_IBVERSO_",")  D
- . W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site.  The versions should be loaded in date order."
+ F IBVERSO=1,1.1,1.2,1.4,2,2.1,2.3,2.4,2.5,2.6,2.7,2.8,2.9 I IBVERSO>IBVERS D
+ . I IBVERSIN[(","_IBVERSO_",") D
+ .. W !!,?5,">>> Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" appears to be already",!,?9,"loaded for this site.  The versions should be loaded in date order."
  ;
  ; check if loading a version when the last version has not yet been loaded
- S VERSTR=","_$$VERSTR(1)_",",VERSTR=$P(VERSTR,IBVERSC,2) ; all versions before current version, reverse order
- S IBVERSO=$P(VERSTR,",",1) I +IBVERSO,IBVERSIN'[(","_IBVERSO_",") D
- . W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site.  The versions should be loaded in date order."
- . W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site.  If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first."
+ F IBVERSO=2.9,2.8,2.7,2.6,2.5,2.4,2.3,2.1,2,1.4,1.2,1.1,1 I IBVERS>IBVERSO D  Q
+ . I IBVERSIN'[(","_IBVERSO_",") D
+ .. W !!,?5,"*** Currently trying to load RC v"_IBVERS_" but RC v"_IBVERSO_" does not appear to be",!,?9,"loaded for this site.  The versions should be loaded in date order."
+ .. W !!,?5,">>> Continue only if there will never be a need to bill events before ",!,?9,$$FMTE^XLFDT(IBVDTC,2)," for this site.  If RC v"_IBVERSO_" will be needed for this site then",!,?9,"load it first."
  ;
  Q
  ;
-VERSTR(RVRS) ; returns string containing list of all Reasonable Charges versions with charges, separated by ","
- ; RVRS - if set, returns the list of versions in reverse order
- N IBI,LINE,IBS,IBR,IBC,IBX  S (IBS,IBR,IBC,IBX)=""
- F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  S IBS=IBS_IBC_+LINE,IBR=+LINE_IBC_IBR S IBC=","
- S IBX=IBS I +$G(RVRS) S IBX=IBR
- Q IBX
+FILES(IBFILES,VERS) ; source Host file name, description, and routine label that parses the file
+ ; the subscript used for the file in XTMP is 'IBCR RC '_X w/ X=the routine label that parses the file
  ;
+ I $G(VERS)=1.1 G FBREAL
+ I $G(VERS)=1.2 G FCREAL
+ I $G(VERS)=1.4 G FDREAL
+ I $G(VERS)=2 G FEREAL
+ I $G(VERS)=2.1 G FFREAL
+ I $G(VERS)=2.3 G FGREAL
+ I $G(VERS)=2.4 G FHREAL
+ I $G(VERS)=2.5 G FIREAL^IBCRHBV1
+ I $G(VERS)=2.6 G FJREAL^IBCRHBV1
+ I $G(VERS)=2.7 G FKREAL^IBCRHBV1
+ I $G(VERS)=2.8 G FLREAL^IBCRHBV1
+ I $G(VERS)=2.9 G FMREAL^IBCRHBV1
  ;
- ;
- ;
- ;
- ;
- ;
- ; File Names:  'IBRCyymmx.TXT'   w/ yymm - year month of version release (except v1)
- ;              'IBRCyymm', file version identifier prefix, from VLIST text version description
- ;              x=A-I/F, single character file identifier, from FTYPE text file description
- ;
-FILES(IBFILES,VERS) ; returns array of source Host Files and data for version requested, pass IBFILES by reference
- N IBI,LINE,IBTYPE,IBFILE,IBNAME,IBDESC S VERS=+$G(VERS) I 'VERS S VERS=1
- ;
- ; get requested versions data
- F IBI=1:1 S LINE=$P($T(VLIST+IBI),";;",2,99) Q:'LINE  I VERS=+LINE S IBTYPE=$P(LINE,U,2),IBFILE=$P(LINE,U,5) Q
- ;
- ; get requested versions files
- I +$G(IBTYPE) F IBI=1:1 S LINE=$P($T(@("FT"_IBTYPE)+IBI),";;",2,99) Q:LINE=""  D
- . S IBNAME=IBFILE_$P(LINE,":",1)_".TXT",IBDESC="RC v"_+VERS_" "_$P(LINE,":",2,99)
- . S IBFILES(IBNAME)=IBDESC
+FREAL S IBFILES("IBRCVA.TXT")="RC v1 Inpatient Facility Charges^A"
+ S IBFILES("IBRCVB.TXT")="RC v1 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRCVC.TXT")="RC v1 Outpatient Facility Charges^C"
+ S IBFILES("IBRCVD.TXT")="RC v1 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRCVE.TXT")="RC v1 Physician Charges E^E"
+ S IBFILES("IBRCVF.TXT")="RC v1 Physician Charges F^F"
+ S IBFILES("IBRCVG.TXT")="RC v1 Physician Charges G^G"
+ S IBFILES("IBRCVH.TXT")="RC v1 Physician Area Factors^H"
+ S IBFILES("IBRCVI.TXT")="RC v1 Physician Unit Area Factors^I"
  Q
  ;
+FBREAL S IBFILES("IBRC0011A.TXT")="RC v1.1 Inpatient Facility Charges^A"
+ S IBFILES("IBRC0011B.TXT")="RC v1.1 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRC0011C.TXT")="RC v1.1 Outpatient Facility Charges^C"
+ S IBFILES("IBRC0011D.TXT")="RC v1.1 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRC0011E.TXT")="RC v1.1 Physician Charges E^E"
+ S IBFILES("IBRC0011F.TXT")="RC v1.1 Physician Charges F^F"
+ S IBFILES("IBRC0011G.TXT")="RC v1.1 Physician Charges G^G"
+ S IBFILES("IBRC0011H.TXT")="RC v1.1 Physician Area Factors^H"
+ S IBFILES("IBRC0011I.TXT")="RC v1.1 Physician Unit Area Factors^I"
+ Q
  ;
- ; versions and their critical data, add new versions here
-VLIST ; version ^ file type/version ^ effective date ^ inactive date ^ file prefix
- ;;1.0^1^2990901^3001101^IBRCV
- ;;1.1^1^3001102^3010507^IBRC0011
- ;;1.2^1^3010508^3030428^IBRC0105
- ;;1.4^1^3030429^3031218^IBRC0304
- ;;2.0^2^3031219^3040414^IBRC0312
- ;;2.1^2^3040415^3041231^IBRC0404
- ;;2.3^2^3050101^3050410^IBRC0501
- ;;2.4^2^3050411^3050930^IBRC0504
- ;;2.5^2^3051001^3051231^IBRC0510
- ;;2.6^2^3060101^3060824^IBRC0601
- ;;2.7^2^3060825^3060930^IBRC0608
- ;;2.8^2^3061001^3061231^IBRC0610
- ;;2.9^2^3070101^3070930^IBRC0701
- ;;2.11^2^3071001^3071231^IBRC0710
- ;;3.1^2^3080101^^IBRC0801
- ;;
- ; 
- ; 
- ; 
- ; 
- ; 
- ; 
- ; 
-FTYPE ; file type/versions and relevant data
- ; file identifer is used with XTMP subscript 'IBCR RC ' and routine label to parse file
- ; file identifier : file name/description ^ file identifier ^ number of columns (for v2+)
+FCREAL S IBFILES("IBRC0105A.TXT")="RC v1.2 Inpatient Facility Charges^A"
+ S IBFILES("IBRC0105B.TXT")="RC v1.2 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRC0105C.TXT")="RC v1.2 Outpatient Facility Charges^C"
+ S IBFILES("IBRC0105D.TXT")="RC v1.2 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRC0105E.TXT")="RC v1.2 Physician Charges E^E"
+ S IBFILES("IBRC0105F.TXT")="RC v1.2 Physician Charges F^F"
+ S IBFILES("IBRC0105G.TXT")="RC v1.2 Physician Charges G^G"
+ S IBFILES("IBRC0105H.TXT")="RC v1.2 Physician Area Factors^H"
+ S IBFILES("IBRC0105I.TXT")="RC v1.2 Physician Unit Area Factors^I"
+ Q
  ;
-FT1 ; Reasonable Charge File Type 1 files
- ;;A:Inpatient Facility Charges^A
- ;;B:Inpatient Facility Area Factors^B
- ;;C:Outpatient Facility Charges^C
- ;;D:Outpatient Facility Area Factors^D
- ;;E:Physician Charges E^E
- ;;F:Physician Charges F^F
- ;;G:Physician Charges G^G
- ;;H:Physician Area Factors^H
- ;;I:Physician Unit Area Factors^I
- ;;
+FDREAL S IBFILES("IBRC0304A.TXT")="RC v1.4 Inpatient Facility Charges^A"
+ S IBFILES("IBRC0304B.TXT")="RC v1.4 Inpatient Facility Area Factors^B"
+ S IBFILES("IBRC0304C.TXT")="RC v1.4 Outpatient Facility Charges^C"
+ S IBFILES("IBRC0304D.TXT")="RC v1.4 Outpatient Facility Area Factors^D"
+ S IBFILES("IBRC0304E.TXT")="RC v1.4 Physician Charges E^E"
+ S IBFILES("IBRC0304F.TXT")="RC v1.4 Physician Charges F^F"
+ S IBFILES("IBRC0304G.TXT")="RC v1.4 Physician Charges G^G"
+ S IBFILES("IBRC0304H.TXT")="RC v1.4 Physician Area Factors^H"
+ S IBFILES("IBRC0304I.TXT")="RC v1.4 Physician Unit Area Factors^I"
+ Q
  ;
-FT2 ; Reasonable Charges File Type 2 files
- ;;A:Inpatient Facility Charges^A^10
- ;;B:Outpatient Facility Charges^B^14
- ;;C:Professional Charges^C^23
- ;;D:Service Category Codes^D^4
- ;;E:Area Factors^E^41
- ;;F:VA Sites and Zip Codes^F^4
- ;;
+FEREAL S IBFILES("IBRC0312A.TXT")="RC v2.0 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0312B.TXT")="RC v2.0 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0312C.TXT")="RC v2.0 Professional Charges^C^23"
+ S IBFILES("IBRC0312D.TXT")="RC v2.0 Service Category Codes^D^4"
+ S IBFILES("IBRC0312E.TXT")="RC v2.0 Area Factors^E^41"
+ S IBFILES("IBRC0312F.TXT")="RC v2.0 VA Sites and Zip Codes^F^4"
+ Q
+ ;
+FFREAL S IBFILES("IBRC0404A.TXT")="RC v2.1 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0404B.TXT")="RC v2.1 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0404C.TXT")="RC v2.1 Professional Charges^C^23"
+ S IBFILES("IBRC0404D.TXT")="RC v2.1 Service Category Codes^D^4"
+ S IBFILES("IBRC0404E.TXT")="RC v2.1 Area Factors^E^41"
+ S IBFILES("IBRC0404F.TXT")="RC v2.1 VA Sites and Zip Codes^F^4"
+ Q
+ ;
+FGREAL S IBFILES("IBRC0501A.TXT")="RC v2.3 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0501B.TXT")="RC v2.3 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0501C.TXT")="RC v2.3 Professional Charges^C^23"
+ S IBFILES("IBRC0501D.TXT")="RC v2.3 Service Category Codes^D^4"
+ S IBFILES("IBRC0501E.TXT")="RC v2.3 Area Factors^E^41"
+ S IBFILES("IBRC0501F.TXT")="RC v2.3 VA Sites and Zip Codes^F^4"
+ Q
+ ;
+FHREAL S IBFILES("IBRC0504A.TXT")="RC v2.4 Inpatient Facility Charges^A^10"
+ S IBFILES("IBRC0504B.TXT")="RC v2.4 Outpatient Facility Charges^B^14"
+ S IBFILES("IBRC0504C.TXT")="RC v2.4 Professional Charges^C^23"
+ S IBFILES("IBRC0504D.TXT")="RC v2.4 Service Category Codes^D^4"
+ S IBFILES("IBRC0504E.TXT")="RC v2.4 Area Factors^E^41"
+ S IBFILES("IBRC0504F.TXT")="RC v2.4 VA Sites and Zip Codes^F^4"
+ Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRHBS8.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCRHBS8 ;ALB/ARH - RATES: UPLOAD (RC 2+) CALCULATIONS CHARGE ; 10-OCT-03
- ;;2.0;INTEGRATED BILLING;**245,382**;21-MAR-94;Build 2
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;
@@ -49,7 +49,6 @@
  ;
 ISNF(SITE,ITLINE) ; Return Inpatient Skilled Nursing Facility Per Diem
- N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4)
- I $P(ITLINE,U,2)'="SNF" G ISNFQ
- I $P(ITLINE,U,1)'="999",$P(ITLINE,U,1)'="000" G ISNFQ
+ N IBCHG,IBZIP,IBAA S IBCHG=0,ITLINE=$G(ITLINE),IBZIP=$P($G(SITE),U,4) I $P(ITLINE,U,2)'="SNF" G ISNFQ
+ I $P(ITLINE,U,1)'="999" G ISNFQ
  ;
  S IBAA=$$GETAA(IBZIP) I $P(IBAA,U,1)'=IBZIP G ISNFQ
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC3.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCSC3 ;ALB/MJB - MCCR SCREEN 3 (PAYER/MAILING ADDRESS) ;27 MAY 88 10:15
- ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**8,43,52,80,82,51,137,232,320**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;MAP TO DGCRSC3
@@ -14,4 +14,5 @@
  F I=0,"M","M1","U","U2" S IB(I)=$S($D(^DGCR(399,IBIFN,I)):(^(I)),1:"")
  S IBOUTP=2,IBINDT=$S(+$G(IB("U")):+IB("U"),1:DT)
+ ;S Z=1,IBW=1 X IBWW W " Rate Type  : ",$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
  ;
  S X=" Rate Type  : "_$S($P(IB(0),U,7)']"":IBU,$D(^DGCR(399.3,$P(IB(0),U,7),0)):$P(^(0),U),1:IBUN)
@@ -30,5 +31,5 @@
  I $P(IB(0),U,11)="i" I $D(IBDD)>1,$D(^DGCR(399,IBIFN,"AIC")) G SHW
  D UP G LST:$D(IBDD)>1 W !?4,"Insurance : NO REIMBURSABLE INSURANCE INFORMATION ON FILE",!?17,"[Add Insurance Information by entering '1' at the prompt below]" G MAIL
- ;
+ ;W !?4,"Insurance Carrier",?40,"Whose",?66,"Relationship" S X="",$P(X,"=",81)="" W !,X
 LST N IBDTIN,IBICT
  S IBDTIN=+$G(IB("U")),IBICT=0
@@ -44,5 +45,4 @@
 SHW I $D(IBDD) S I="" F  S I=$O(IBDD(I)) Q:'I  D SHW1
 MAIL I $$BUFFER^IBCNBU1(DFN) W !!,?17,"***  Patient has Insurance Buffer entries  ***"
- ;
  S IB("M")=$S($D(^DGCR(399,IBIFN,"M")):^("M"),1:""),IB("M1")=$S($D(^DGCR(399,IBIFN,"M1")):^("M1"),1:""),IB(0)=^DGCR(399,IBIFN,0)
  S Z=2,IBW=1 W ! X IBWW
@@ -52,14 +52,9 @@
  S IB("RAFLAG",2)=$S($P(IB("M"),U,2)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,2),IBRAMS,"I"))
  S IB("RAFLAG",3)=$S($P(IB("M"),U,3)="":0,1:$$GET1^DIQ(36,$P(IB("M"),U,3),IBRAMS,"I"))
- S X=0
- I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1
- W " Billing Provider Secondary IDs: "
- I X W IBUN          ; no data found, unspecified not required
- I 'X D              ; data found, display below
- . W !?5,"Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
- . W !?5,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
- . W ?46,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
- . Q
- ;
+ S X=0 I $P(IB("M1"),U,2)="",'IB("RAFLAG",1),$P(IB("M1"),U,3)="",'IB("RAFLAG",2),$P(IB("M1"),U,4)="",'IB("RAFLAG",3) S X=1 W " Facility ID #s: ",IBUN
+ I 'X D
+ . W " Primary Payer: ",$S($P(IB("M1"),U,2)]"":$P(IB("M1"),U,2),IB("RAFLAG",1):"ATT/REND ID",1:"")
+ . W !?4,"Secondary Payer: ",$S($P(IB("M1"),U,3)]"":$P(IB("M1"),U,3),IB("RAFLAG",2):"ATT/REND ID",1:"")
+ . W ?45,"Tertiary Payer: ",$S($P(IB("M1"),U,4)]"":$P(IB("M1"),U,4),IB("RAFLAG",3):"ATT/REND ID",1:"")
  S Z=3,IBW=1 W ! X IBWW
  W " Mailing Address : "
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCSC5 ;ALB/MJB - MCCR SCREEN 5 (OPT. EOC) ;27 MAY 88 10:15
- ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,125,51,210,266,288,287,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;MAP TO DGCRSC5
@@ -58,5 +58,6 @@
  . S IBY=0 F  S IBY=$O(^IBA(362.5,"AIFN"_IBIFN,IBX,IBY)) Q:'IBY  S IBZ=$G(^IBA(362.5,IBY,0)) I IBZ'="" D  Q:X>5
  .. S X=X+1 I X>5 W !,?17,"*** There are more Pros. Items associated with this bill.***" Q
- .. W:X'=1 ! W ?17,$E($P(IBZ,U,5),1,40),?67,$$FMTE^XLFDT(+IBZ)
+ .. ;S IBN=$G(^RMPR(661,+$P(IBZ,U,3),0)) W:X'=1 ! W ?17,$E($$PIN^IBCSC5B(+IBN),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ)
+ .. S IBN=$$PIN^IBCSC5B(+$P(IBZ,U,3)) W:X'=1 ! W ?17,$E($P(IBN,U,2),1,35)," - ",$P(IBN,U,1),?65,$$FMTE^XLFDT(+IBZ)
  Q X
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC5B.m	(revision 636)
@@ -1,155 +1,92 @@
 IBCSC5B ;ALB/ARH - ADD/ENTER PROSTHETIC ITEMS ;12/28/93
- ;;2.0;INTEGRATED BILLING;**4,52,260,339,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**4,52,260,339**;21-MAR-94;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
  ;
-EN ; add/edit prosthetic items for a bill, IBIFN required
- N IBX,DFN,IBDT1,IBDT2,IBACTION,BIFN,APROS,ALPROS,ABILL,ALBILL
+EN ;add/edit prosthetic items for a bill, IBIFN required
  S IBX=$$BILL(IBIFN) Q:'IBIFN  S DFN=+IBX,IBDT1=$P(IBX,U,2),IBDT2=$P(IBX,U,3)
+ D SET(IBIFN,.IBPDA),PIDISP(DFN,IBDT1,IBDT2,.IBPDE,.IBPDA),DISP(.IBPDA)
+E1 S IBPIFN=0,IBDT=$$ASKDT(IBDT1,IBDT2) G:'IBDT EXIT
+ S IBPD=$O(IBPDA(IBDT,0)) S:'IBPD IBPD=$O(IBPDE(IBDT,0)) S IBPD=$$ASKPD(IBPD) G:'IBPD E1
+ S IBPIFN=$G(IBPDA(IBDT,+IBPD)) I 'IBPIFN S IBPIFN=$$ADD(IBDT,IBIFN,+IBPD,+$G(IBPDE(IBDT,+IBPD))) I 'IBPIFN W " ??" G E1
+ I '$D(IBPDE(IBDT,+IBPD)) W !,"This prosthetic item does not exist in this patients prosthetics record.",!
+ D EDIT(+IBPIFN) D SET(IBIFN,.IBPDA) W ! G E1
  ;
-EN1 D PISET(DFN,IBDT1,IBDT2,.APROS,.ALPROS) D SET(IBIFN,.ABILL,.ALBILL,+$G(APROS))
- D PIDISP(.APROS,.ALPROS,.ABILL) D DISP(.ABILL,.ALBILL) S BIFN=""
- ;
- S IBACTION=$$SELECT(.ALPROS,.ALBILL) Q:'IBACTION
- I +IBACTION=1 S BIFN=$$ADD(IBIFN,$P(IBACTION,U,2),$P(IBACTION,U,3)) G EN1
- I +IBACTION=2 S BIFN=+$G(ABILL(+$P(IBACTION,U,2),$P(IBACTION,U,3)))
- I +IBACTION=3 S IBX=$$ASKITM(IBDT1,IBDT2) I +IBX S BIFN=$$ADD(IBIFN,+IBX,,$P(IBX,U,2))
- I +BIFN D EDIT(BIFN)
- ;
- G EN1
+EXIT K IBPIFN,IBX,IBDT1,IBDT2,IBPDA,IBPDE,IBPD,IBDT
  Q
  ;
-SELECT(ALPROS,ALBILL) ; get which item to add/edit, select from Patient Prosthetics, Bill Items, or add a new one
- ; returns 1 ^ PD DEL DATE ^ PI IFN - ALPROS(selected item) if item from Prosthetics selected
- ;         2 ^ PD DEL DATE ^ X      - ALBILL(selected item) if item existing on bill selected
- ;         3 if add new item, "" if exit, -1 if redo
- N IBX,IBY,IBZ,DIR,DTOUT,DUOUT,DIRUT,X,Y S IBY=""
- S DIR("?")="Select the Prosthetics Item to Add or Edit."
- S DIR("?",1)="Enter the number preceding the Item to Add or Edit."
- S DIR("?",2)="Or enter the Item name to add an item not in the list and not in Prosthetics.",DIR("?",3)=" "
+ASKDT(IBDT1,IBDT2,IBDT) ;
+ I +$G(IBIFN) S DIR("?")="Enter the date the item was delivered to the patient",DIR("??")="^D HELP^IBCSC5B("_IBIFN_")"
+ S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR K DIR,DTOUT,DIRUT
+ Q $S(Y?7N:Y,1:0)
  ;
- S DIR("A")="Select Prosthetics Item",DIR(0)="FO^1:20^K:X?1N1P.NP X" D ^DIR S IBX=Y I $D(DIRUT) G SELECTQ
+ASKPD(PD) ;
+ N X,Y
+ S DIR("A")="Select PROSTHETIC ITEM",DIR(0)="660,4O" S:+$G(PD) DIR("B")=+$G(^RMPR(661,+$G(PD),0)) D ^DIR S:$D(DIRUT)!(Y'>0) Y="" K DIR,DIRUT
+ Q Y
  ;
- S IBZ=$G(ALPROS(IBX)) I +IBZ W "  adding ",IBX S IBY="1^"_IBZ G SELECTQ
- S IBZ=$G(ALBILL(IBX)) I +IBZ W "  editing ",IBX S IBY="2^"_IBZ G SELECTQ
+ADD(IBDT,IFN,IBPD,PIFN) ;
+ N IBX,IBY,IBDX,IBHCPCS S IBX=0,DIC="^IBA(362.5,",DIC(0)="AQL",X=IBDT K DA,DO D FILE^DICN K DA,DO,X
+ I Y>0 S DIE=DIC,(IBX,DA)=+Y,DR=".02////"_IFN_";.03////"_IBPD_";.04////"_PIFN D ^DIE K DIE,DIC,DA,DR W "... ADDED"
+ ;add dx if known
+ F IBY=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBY)) I IBDX,'$O(^IBA(362.3,"AIFN"_IFN,IBDX)) D
+ . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IFN K DD,DO D FILE^DICN S IBDX(+Y)=""
+ ;add hcpcs if known
+ ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS
  ;
- S DIR(0)="YO",DIR("A")="Add a New Item",DIR("B")="YES" D ^DIR K DIR S IBY=-1 I Y=1,'$D(DIRUT) S IBY=3
+ Q IBX
  ;
-SELECTQ Q IBY
- ;
-ASKITM(IBDT1,IBDT2) ; Ask for new item data when adding an item not in Prosthetics
- ; returns:  delivery date ^ prosthetic item name (from 661.1, .02)
- N DIR,DIC,DIE,DTOUT,DUOUT,DIRUT,X,Y,IBX,IBY S (IBX,IBY)="" I '$G(IBDT1)!'$G(IBDT2) G ASKITMQ
- ;
- W !!,"Enter a Prosthetics Item that does not have a Prosthetics Patient record.",!
- S DIR("A")="Select ITEM DELIVERY DATE",DIR(0)="DO^"_IBDT1_":"_IBDT2_":EX" D ^DIR S IBX=Y I Y'?7N G ASKITMQ
- ;
- S DIC="^RMPR(661.1,",DIC(0)="AENOQMZ",DIC("S")="I +$P(^(0),U,5)",DIC("A")="Select PROSTHETICS ITEM: " D ^DIC
- ;
- I +Y>0,+IBX S IBY=IBX_U_$P($G(Y(0)),U,2)
- ;
-ASKITMQ Q IBY
- ;
-ADD(IBIFN,IBDT,PIFN,IBPNAME) ; Add new Item to Bill (#362.5)
- N IBX,IBY,IBDX,IBHCPCS,DIC,DIE,DA,DR,DLAYGO,X,Y S IBY=0,PIFN=+$G(PIFN) I ($G(IBDT)'?7N)!('$G(IBIFN)) G ADDQ
- ;
- I $G(PIFN),$$ONBILLPI(IBIFN,PIFN) G ADDQ ; don't add duplicates
- I $G(IBPNAME)="" S IBPNAME=$P($$PIN(PIFN),U,2) I IBPNAME="" G ADDQ
- ;
- S DIC="^IBA(362.5,",DIC(0)="AQL",DLAYGO=362.5,X=IBDT K DA,DO D FILE^DICN K DA,DO,X
- I Y>0 S (IBY,DA)=+Y,DIE=DIC,DR=".02////"_IBIFN_";.04////"_+PIFN_";.05///^S X=IBPNAME" D ^DIE K DIE,DA,DR W "... ADDED"
- ;
- ;add dx if known
- I +IBY,+PIFN F IBX=1:1:4 S IBDX=+$G(^RMPR(660,PIFN,"BA"_IBX)) I IBDX,'$O(^IBA(362.3,"AIFN"_IBIFN,IBDX)) D
- . S DIC="^IBA(362.3,",DIC(0)="L",DLAYGO=362.3,X=IBDX,DIC("DR")=".02////"_IBIFN K DD,DO D FILE^DICN S IBDX(+Y)=""
- ;add hcpcs if known ;S IBHCPCS=$P($G(^RMPR(660,PIEN,0)),"^",22) I IBHCPCS
- ;
-ADDQ Q IBY
- ;
-EDIT(BIFN) ;
- N DIDEL,DIE,DIC,DR,DA,X,Y Q:'$G(BIFN)  W ! S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.05",DA=BIFN D ^DIE
+EDIT(PIFN) ;
+ S DIDEL=362.5,DIE="^IBA(362.5,",DR=".01;.03",DA=PIFN D ^DIE K DIE,DR,DA,DIC,DIDEL
  Q
  ;
-SET(IBIFN,ARRB,ARRBL,PICNT) ; setup array of all prosthetic devices on bill (#362.5), array names should be passed by reference
- ; input:   PICNT - the number of items found in prosthetics (PISET)
- ; output:  ARRB(PD DELIV DATE, X) = PD IFN (362.5 ptr) ^ Cost,  ARRB = BILL IFN ^ count of items on bill
- ;          ARRBL(PICNT + count of item on bill) = PD DELIV DATE ^ X
- ;          where X is the IFN of the Patient Item (660 ptr) or if not defined then a number_"Z"
- N CNT,IBX,IBY,BIFN,RIFN,IBC,IBRC K ARRB,ARRBL S IBC="AIFN"_$G(IBIFN),ARRB="^0" Q:'$G(IBIFN)
- D RCITEM^IBCSC5A(IBIFN,"IBRC",5) S CNT=0
- ;
- S IBX=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S BIFN=0 F  S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN  D
- . S IBY=$G(^IBA(362.5,BIFN,0)) Q:IBY=""  S CNT=CNT+1,RIFN=+$P(IBY,U,4),RIFN=$S(+RIFN:+RIFN,1:CNT_"Z")
- . S ARRB(+IBY,RIFN)=BIFN_U_$$CHG^IBCF4(BIFN,5,.IBRC),ARRB=$G(ARRB)+1
- S ARRB=IBIFN_U_+$G(ARRB)
- ;
- S CNT=+$G(PICNT),IBX=0 F  S IBX=$O(ARRB(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(ARRB(IBX,IBY)) Q:'IBY  S CNT=CNT+1,ARRBL(CNT)=IBX_U_IBY
+SET(IFN,PDARR) ;setup array of all prosthetic devices for bill, array name should be passed by reference
+ ;returns: PDARR(PD DELIV DATE, PD ITEM (661 ptr))=PD IFN (362.5 ptr),  PDARR=BILL IFN ^ PD count
+ N CNT,IBX,IBY,PIFN,IBC,IBRC K PDARR S IBC="AIFN"_$G(IFN)
+ D RCITEM^IBCSC5A(IBIFN,"IBRC",5)
+ S (CNT,IBX)=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S PIFN=0 F  S PIFN=$O(^IBA(362.5,IBC,IBX,PIFN)) Q:'PIFN  D
+ . S IBY=$G(^IBA(362.5,PIFN,0)) Q:IBY=""  S CNT=CNT+1,PDARR(+IBY,$P(IBY,U,3))=PIFN_U_$$CHG^IBCF4(PIFN,5,.IBRC)
+ S PDARR=$G(IFN)_"^"_CNT
  Q
  ;
-DISP(ABILL,ALBILL) ;screen display of existing prosthetic devices for a bill, arrays should be passed by reference
- ; input:  ABILL (from SET) list of bill items
- ;         ALBILL (from SET) list of bill items, in count order
- N IBC,IBI,BIFN,BIFN0,DDT
- ;
+DISP(PDARR) ;screen display of existing prosthetic devices for a bill,
+ ;input should be array returned by SET^IBCSC5B: PDARR(PD DT, PD ITEM)=PD IFN (362.5), pass by reference
+ N IBX,IBY,IBZ
  W !!,?5,"-----------------  Existing Prosthetic Items for Bill  -----------------",!
- S IBC=0 F  S IBC=$O(ALBILL(IBC)) Q:'IBC  D
- . S DDT=+ALBILL(IBC),IBI=$P(ALBILL(IBC),U,2),BIFN=+$G(ABILL(DDT,IBI)),BIFN0=$G(^IBA(362.5,BIFN,0))
- . W !,?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(BIFN0,U,5),1,60)
+ S IBX=0 F  S IBX=$O(PDARR(IBX)) Q:IBX=""  S IBY=0 F  S IBY=$O(PDARR(IBX,IBY)) Q:'IBY  D
+ . S IBZ=$$PIN(IBY) W !,$$DATE(IBX),?12,$P(IBZ,U,1),?20,$P(IBZ,U,2)
  W !
  Q
  ;
-PISET(DFN,DT1,DT2,ARRP,ARRPL) ; get all prosthetic items (660) for a patient and date range, arrays should pass by ref.
- ; input:   DFN = patient, DT1-DT2 range of dates to search for items
- ; output:  ARRP(PD DEL DATE (660,10), PI IFN (660 ptr)) = PI IFN (660 ptr),  ARRP = count of items
- ;          ARRPL(count) = PD DEL DATE (660,10) ^ PI IFN (660 ptr)
- ;
- N PIFN,DDT,IBX,IBY,CNT K ARRP,ARRPL Q:'$G(DFN)  S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999
- S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D
- . S IBX=$G(^RMPR(660,PIFN,0)) Q:IBX=""  S DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q
- . S ARRP(DDT,PIFN)=PIFN,ARRP=+$G(ARRP)+1
- ;
- S (CNT,IBX)=0 F  S IBX=$O(ARRP(IBX)) Q:'IBX  S IBY=0 F  S IBY=$O(ARRP(IBX,IBY)) Q:'IBY  S CNT=CNT+1,ARRPL(CNT)=IBX_U_IBY
+HELP(IFN) ;called for help from prosthetics enter to display existing devices, displays devices from 660 and 399
+ I +$G(IFN) N IBX,IBPDA S IBX=$$BILL(IFN) I +IBX D SET(IFN,.IBPDA),PIDISP($P(IBX,U,1),$P(IBX,U,2),$P(IBX,U,3),"",.IBPDA),DISP(.IBPDA)
  Q
  ;
-PIDISP(APROS,ALPROS,ABILL) ; display all prosthetic items (#660) for a patient and date range, arrays passed by reference, not changed
- ; input:  APROS (from PISET) patient's prosthetic items
- ;         ALPROS (from PISET) patient's prosthetics items, in count order
- ;         ABILL (from SET) list of bill's prosthetics items, only to check if item on bill
- N IBC,DDT,PIFN,PNAME,IBY,IBX,IBICD,IBP,IBEX
+PIDISP(DFN,DT1,DT2,ARRAY,PDARR) ; display all prosthetic items (660) for a patient and date range
+ ;PDARR (as defined by SET^IBCSC5B) passed by ref. only to check if pros. item is on the bill, not necessary, not changed
+ ;returns ARRAY(PD DEL DATE (660,10), PD ITEM (660,4=661 ptr))=RECORD (660 ptr), should pass by ref. if desired
+ N PIFN,IBX,IBY,PNAME,DDT,PI,IBICD,IBEX,IBP
+ K ARRAY S DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
+ S PIFN=0 F  S PIFN=$O(^RMPR(660,"C",DFN,PIFN)) Q:'PIFN  D
+ . S IBX=$G(^RMPR(660,PIFN,0)),DDT=+$P(IBX,U,12)\1 I (DDT<DT1)!(DDT>DT2) Q
+ . S ARRAY(DDT,+$P(IBX,U,6))=PIFN
  ;
- W @IOF,?33,"PROSTHETICS SCREEN"
- W !,"================================================================================",!
- S IBC=0 F  S IBC=$O(ALPROS(IBC)) Q:'IBC  D
- . S DDT=+ALPROS(IBC),PIFN=$P(ALPROS(IBC),U,2)
- . S PNAME=$$PIN(PIFN),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX
- . ;
- . F IBICD=1:1:4 Q:$D(IBEX)  I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q  ; look for exemption info
- . ;
- . W !,$S($D(ABILL(+DDT,PIFN)):"*",1:"")
- . W ?1,$J(IBC,2),")",?6,$$DATE(DDT),?16,$E($P(PNAME,U,2),1,27),?45,"("_$P(PNAME,U,3),")",?53,$G(IBEX),?59,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?64,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?71,$J(+$P(IBX,U,16),8,2)
+ W @IOF,?33,"PROSTHETICS SCREEN",!,"================================================================================",!
+ S DDT=0 F  S DDT=$O(ARRAY(DDT)) Q:'DDT  S PI=0 F  S PI=$O(ARRAY(DDT,PI)) Q:'PI  D
+ . S PIFN=ARRAY(DDT,PI),PNAME=$$PIN(PI),IBY=$G(^RMPR(660,PIFN,"AM")),IBX=$G(^RMPR(660,PIFN,0)) K IBEX
+ . ; look for exemption info
+ . F IBICD=1:1:4 Q:$D(IBEX)  I $D(^RMPR(660,PIFN,"BA"_IBICD)) F IBP=2:1:8 I $P(^RMPR(660,PIFN,"BA"_IBICD),"^",IBP) S IBEX="("_$P($T(EXEMPT+(IBP-1)),";",3)_")" Q
+ . W !,$S($D(PDARR(+DDT,PI)):"*",1:"")
+ . W ?2,$$DATE(DDT),?12,$P(PNAME,U,1),$G(IBEX),?20,$E($P(PNAME,U,2),1,30),?55,$E($$EXSET^IBEFUNC($P(IBX,U,14),660,12),1,4),?62,$$EXSET^IBEFUNC($P(IBY,U,3),660,62),?70,$J(+$P(IBX,U,16),9,2)
  Q
  ;
-PIN(P660,P6611) ; given Prosthetic record (#660) or PSAS HCPCS (#661.1) return Item Name
- ; returns PSAS HCPSC ptr (661.1) ^ SHORT DESCRIPTION (661.1, .02) ^ HCPCS (661.1, .01)
- N IBX,IBY S IBY=""
- I +$G(P660) S P6611=+$P($G(^RMPR(660,+P660,1)),U,4)
- I +$G(P6611) S IBX=$G(^RMPR(661.1,+P6611,0)) I IBX'="" S IBY=P6611_U_$P(IBX,U,2)_U_$P(IBX,U,1)
+PIN(PITEM) ;given the pros item IFN (661 ptr) returns name for printing (661,.01^441,.05)
+ N IBX,IBY S IBY="" I +$G(PITEM) S IBX=+$G(^RMPR(661,+PITEM,0)) I +IBX S IBY=IBX_U_$$DESCR^PRCPUX1(0,+IBX)
  Q IBY
  ;
-PINB(P3625) ; given the bill prosthetics item (#362.5) return Item Name (.05)
- N IBY S IBY=$P($G(^IBA(362.5,+$G(P3625),0)),U,5)
- Q IBY
- ;
-BILL(IBIFN) ; get bill data: returns DFN ^ Statement Covers From ^ Statement Covers To
- N IBX,IBY S IBIFN=+$G(IBIFN) S IBX=$G(^DGCR(399,IBIFN,0)),IBY=$P(IBX,U,2)
- S IBX=$G(^DGCR(399,IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
- Q IBY
- ;
-ONBILLPI(IBIFN,PIFN) ; return Bill Item ptr (#362.5) if the Prosthetics Item (#660) is already assigned to the bill
- ; input:  PIFN = Patient Prosthetics Item (ptr to 660)
- ; output: BIFN = Bill Prosthetics Item (ptr to 362.5) or null if not found
- N IBC,IBX,IBY,BIFN S IBY="" S IBC="AIFN"_$G(IBIFN)
- S IBX=0 F  S IBX=$O(^IBA(362.5,IBC,IBX)) Q:'IBX  S BIFN=0 F  S BIFN=$O(^IBA(362.5,IBC,IBX,BIFN)) Q:'BIFN  D
- . I +$G(PIFN),$P($G(^IBA(362.5,BIFN,0)),U,4)=PIFN S IBY=BIFN
+BILL(IBIFN) ; display all existing prescription refills (52) for a patient and date range
+ ; (call is a short cut to calling rxdisp if have bill number)
+ N IBX,IBY S IBX=$G(^DGCR(399,+$G(IBIFN),0)),IBY=$P(IBX,U,2)
+ S IBX=$G(^DGCR(399,+IBIFN,"U")),$P(IBY,U,2)=+IBX,$P(IBY,U,3)=+$P(IBX,U,2)
  Q IBY
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC61.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCSC61 ;ALB/MJB - MCCR SCREEN UTILITY ;20 JUN 88 10:58
- ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**52,80,106,51,210,230,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;MAP TO IBCSC61
@@ -35,5 +35,5 @@
  .K ^TMP($J,"IBDRUG")
  .Q
- I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($G(^IBA(362.5,+ITEM,0)),U,5)
+ I $G(TYPE)=5,+$G(ITEM) S IBNAME=$P($$PIN^IBCSC5B(+$P($G(^IBA(362.5,+ITEM,0)),U,3)),U,2)
  I $G(TYPE)=6,+$G(ITEM) S IBNAME=$P($$DRG^IBACSV(+ITEM),U,1)
  I $G(TYPE)=9,+$G(ITEM) S IBNAME=$P($G(^IBA(363.21,+ITEM,0)),U,1)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSC8H.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCSC8H ;ALB/ARH - MCCR SCREEN 8 (BILL SPECIFIC INFO) CMS-1500 ;4/21/92
- ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**51,137,207,210,232,155,320,343,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ; CMS-1500 screen 8
@@ -7,5 +7,5 @@
  ;
 EN N I,IB,Y,Z
- D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="00000000" S:IBV IBV1="11111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
+ D ^IBCSCU S IBSR=8,IBSR1="H",IBV1="0000000" S:IBV IBV1="1111111" F I="U","U1","UF2","UF3","U2","M","TX",0,"U3" S IB(I)=$G(^DGCR(399,IBIFN,I))
  N IBZ,IBPRV,IBDATE,IBREQ,IBMRASEC,IBZ1
  ;
@@ -91,7 +91,4 @@
  ;
  S Z=5,IBW=1 X IBWW
- W " Chiropractic Data  : " S Y=$P(IB("U3"),U,5) X ^DD("DD") W $S(Y'="":"INITIAL TREATMENT ON "_Y,1:IBUN)
- ;
- S Z=6,IBW=1 X IBWW
  W " Form Locator 19    : " S IBZ=$P($G(^DGCR(399,IBIFN,"UF31")),U,3) W $S(IBZ'="":IBZ,1:IBUN)
  I $P(IB("U2"),U,14)'="" W !,?4,"Homebound          : ",$$EXPAND^IBTRE(399,236,$P(IB("U2"),U,14))
@@ -99,5 +96,5 @@
  I $P(IB("U2"),U,16)'="" W !,?4,"Spec Prog Indicator: " S IBZ=$$EXPAND^IBTRE(399,238,$P(IB("U2"),U,16)) W $S(IBZ'="":IBZ,$$WNRBILL^IBEFUNC(IBIFN):"31",1:"")
  ;
- S Z=7,IBW=1 X IBWW
+ S Z=6,IBW=1 X IBWW
  S IBREQ=+$$REQMRA^IBEFUNC(IBIFN) S:IBREQ IBREQ=1
  S IBMRASEC=$$MRASEC^IBCEF4(IBIFN)
@@ -107,5 +104,5 @@
  W $S(IBZ'=""&($P(IB("TX"),U,8+IBREQ)'=""):IBZ,'$$TXMT^IBCEF4(IBIFN):"[NOT APPLICABLE - NOT TRANSMITTABLE]",IBREQ:"NO FORCED PRINT",1:IBZ)
  ;
- S Z=8,IBW=1 X IBWW
+ S Z=7,IBW=1 X IBWW
  W " Provider ID Maint  : (Edit Provider ID information)",!
  G ^IBCSCP
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCE.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCSCE ;ALB/MRL,MJB - MCCR SCREEN EDITS ;07 JUN 88 14:35
- ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,80,91,106,51,137,236,245,287,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -17,7 +17,6 @@
  I (IBDR20["45")!(IBDR20["56") D ^IBCSC5B G ENQ
  I (IBDR20["66")!(IBDR20["76") D EDIT^IBCRBE(IBIFN) D ASKCMB^IBCU65(IBIFN) G ENQ
- I IBDR20["85",$$FT^IBCEF(IBIFN)=2 D ^IBCSC8A G ENQ ; chiropractic data
  I IBDR20["84",$$FT^IBCEF(IBIFN)=3 D EN1^IBCEP6 G ENQ   ;UB-04
- I IBDR20["88",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ;CMS-1500
+ I IBDR20["87",$$FT^IBCEF(IBIFN)=2 D EN1^IBCEP6 G ENQ   ;CMS-1500
  F Q=1:1:9 I IBDR20[("9"_Q) D EDIT^IBCSC9 G ENQ
 TMPL N IBFLIAE S IBFLIAE=1 ;to invoke EN^DGREGAED from [IB SCREEN1]
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCSCH ;ALB/MJB - MCCR HELP ROUTINE ;03 JUN 88 15:25
- ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374,371,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**52,80,106,124,138,51,148,137,161,245,232,287,348,349,374**;21-MAR-94;Build 16
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -19,5 +19,4 @@
  . I $G(IBSCNNZ)="?MRA",$$MCRONBIL^IBEFUNC(IBIFN),$T(SCR^IBCEMVU)'="" S IBQ=1 D SCR^IBCEMVU(IBIFN) Q
  . I $G(IBSCNNZ)="?ID" S IBQ=1 D DISPID^IBCEF74(IBIFN) Q
- . I $G(IBSCNNZ)="?RX" S IBQ=1 D DISPRX^IBCSCH1(IBIFN) Q
  . Q
  ;
@@ -40,5 +39,4 @@
  I $$MCRONBIL^IBEFUNC(IBIFN) W !?5,"Enter '?MRA' to view Medicare Remittance Advice EOB's on file."
  W !,?5,"Enter '?ID' to view all IDs to be electronically transmitted on this claim."
- W !,?5,"Enter '?RX' to view all prescriptions on this claim."
  ;
  I +IBSR'=9 S Z="DATA GROUPS ON SCREEN "_+IBSR W ! X IBWW D @(IBSR1_IBSR) D W
@@ -57,5 +55,5 @@
 9 S X="Locally defined fields" Q
 28 S X="Bill Remark, ICN/DCN's, Tx Auth. Code, Admit Diagnosis/Source ^Providers^Force to Print^Provider ID Maintenance^Other Facility (VA/non)" Q
-H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Chiropractic Data^Form Locator 19^Force to Print^Provider ID Maintenance" Q
+H8 S X="Period Unable to Work^Admit Dx, ICN/DCN, Tx/Prior Auth. Code^Providers^Non-VA Facility^Form Locator 19^Force to Print" Q
 PAR S X="Fed Tax #, BC/BS #, MAS Svc Pointer^Bill Signer, Billing Supervisor^Security Parameters, Outpatient CPT parameters ^Remarks, Mailgroups^Agent Cashier Address/Phone" Q
 S N C,I,Z,J W !! S Z="AVAILABLE SCREENS" X IBWW
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCSCH1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCSCH1 ;ALB/MRL - BILLING HELPS (CONTINUED) ; 01 JUN 88 12:00
- ;;2.0;INTEGRATED BILLING;**106,125,51,245,266,395**;21-MAR-94;Build 3
+ ;;2.0;INTEGRATED BILLING;**106,125,51,245,266**;21-MAR-94
  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
@@ -69,35 +69,2 @@
  N DIR,DUOUT,DTOUT,DIRUT,IBX,X,Y S IBX=0,DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S IBX=1
  Q IBX
- ;
-DISPRX(IBIFN) ; display prescriptions
- N IBHDR,IBHDR1,IBX,IBZ,IBRXL,IBNPI,IBRX,IBQ,IBORG
- S IBQ=0
- ;
- I '$O(^IBA(362.4,"AIFN"_IBIFN,0)) W !!?5,"No Prescriptions Entered!",! D PAUSE^VALM1 Q
- ;
- ; get NPIs
- S IBX=$$RXSITE^IBCEF73A(IBIFN,.IBRXL)
- ;
- S IBHDR="W @IOF,!,""Prescriptions Assigned to this Bill"" X IBHDR1"
- S IBHDR1="W !,""--------------------------------------------------------------------------------"" "
- ;
- X IBHDR
- S IBRX=0 F  S IBRX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX)) Q:'IBRX!(IBQ)  S IBX=0 F  S IBX=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBX)) Q:'IBX!(IBQ)  D
- . S IBZ=$G(^IBA(362.4,IBX,0))
- . W !?5,"RX #: ",$P(IBZ,"^")
- . W ?50,"DATE: ",$$FMTE^XLFDT($P(IBZ,"^",3))
- . W !?5,"DRUG: ",$$EXTERNAL^DILFD(362.4,.04,"",$P(IBZ,"^",4))
- . W ?50,"NDC: ",$P(IBZ,"^",8)
- . W !?5,"DAYS SUPPLY: ",$P(IBZ,"^",6)
- . W ?50,"QUANTITY: ",$P(IBZ,"^",7)
- . S IBORG=$G(IBRXL(+$P(IBZ,"^",5),+$P(IBZ,"^",3)))
- . ; ia #4532
- . S IBNPI=$S(IBORG:$P($$NPI^XUSNPI("Organization_ID",IBORG),U),1:"")
- . W !?5,"NPI INSTITUTION: ",$S(IBORG:$$EXTERNAL^DILFD(350.9,.02,"",IBORG),1:"")
- . W ?50,"RX NPI: ",$S(IBNPI>0:IBNPI,1:"")
- . W !?5,"PROVIDER: ",$S($P(IBZ,"^",5):$$RXAPI1^IBNCPUT1($P(IBZ,"^",5),4),1:""),!
- . I $Y+7>IOSL S IBQ=$$PAUSE(0)
- D PAUSE^VALM1
- ;
- Q
- ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU4.m	(revision 636)
@@ -1,4 +1,4 @@
-IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ;12-FEB-90
- ;;2.0;INTEGRATED BILLING;**109,122,137,245,349,371**;21-MAR-94;Build 57
+IBCU4 ;ALB/AAS - BILLING UTILITY ROUTINE (CONTINUED) ; 12-FEB-90
+ ;;2.0;INTEGRATED BILLING;**109,122,137,245,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -50,12 +50,5 @@
  Q
  ;
-CHDAT ; Input transform for chiropractics-related dates (399/245,246,247)
- ; Make sure that date entered is not after end date of the bill
- Q:'$D(X)
- N IBX,Y
- S IBX=$P($G(^DGCR(399,+DA,"U")),U,2)
- I IBX="" W !?4,*7,"No end date of the bill on file - can't enter chiropractics-related dates " K X Q
- I X>+IBX S Y=IBX D DD^%DT W !,?4,*7,"This date can not be after the end date of the claim ("_Y_") " K X Q
- Q
+ ;
  ;
 TO ;151 pseudo input x-form
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU7.m	(revision 636)
@@ -1,5 +1,5 @@
 IBCU7 ;ALB/AAS - INTERCEPT SCREEN INPUT OF PROCEDURE CODES ;29-OCT-91
- ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348,371**;21-MAR-94;Build 57
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**62,52,106,125,51,137,210,245,228,260,348**;21-MAR-94;Build 5
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;MAP TO DGCRU7
@@ -136,5 +136,5 @@
  D ^DIR K DIR
  I Y'=1 S IBOK=0 G ADDTNLQ
- S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03"
+ S DR="W !,""  <<EPSDT>>"";50.07;W !!,""  <<HOSPICE>>"";50.03;W !!,""  <<CHIROPRACTIC>>"";50.04;50.02;50.05;50.06"
  D ^DIE
  W !
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA0.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT.  ;04 AUG 88 03:02
- ;;2.0;INTEGRATED BILLING;**52,361,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,361**;21-MAR-94;Build 9
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -32,6 +32,7 @@
  E  S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex
  S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED")
- S IBIRN(I)=$P(IBDD(I,0),U,16)
- S IBIR(I)=$$EXTERNAL^DILFD(2.312,16,,IBIRN(I))
+ S IBIRN(I)=$P(IBDD(I,0),U,16),IBIR(I)=$S(IBIRN(I)="01":"PATIENT",IBIRN(I)="02":"SPOUSE",IBIRN(I)="03":"CHILD",IBIRN(I)="08":"EMPLOYEE",IBIRN(I)="11":"ORGAN DONOR",IBIRN(I)="18":"PARENT",IBIRN(I)=15:"PLANTIFF",1:"UNKNOWN")
+ I IBIR(I)="UNKNOWN" S IBIR(I)=$S('$D(IBDD(I,0)):"UNKNOWN",$P(IBDD(I,0),U,6)="v":"PATIENT",$P(IBDD(I,0),U,6)="s":"SPOUSE",1:"UNKNOWN")
+ ;S IBIUTL(I)=IBDD(I,0)_"^"_IBISEX(I)_"^"_IBIRN(I)
  Q
 ADDR ;SET ADDRESS
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCVA1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBCVA1 ;ALB/MJB - SET MCCR VARIABLES CONT. ;09 JUN 88 14:49
- ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349,371**;21-MAR-94;Build 57
+ ;;2.0;INTEGRATED BILLING;**52,80,109,51,137,210,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -89,5 +89,5 @@
  S IBX=0 F  S IBX=$O(^DGCR(399,IBIFN,"CV",IBX)) Q:'IBX  S IBY=$G(^DGCR(399,IBIFN,"CV",IBX,0)) I +IBY D
  . S IBVC=IBVC+1,IBZ=$G(^DGCR(399.1,+IBY,0)) Q:IBZ=""
- . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S($P(IBY,U,2)="":"",+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)
+ . S IBVC(+IBY)=$P(IBZ,U,2)_U_$P(IBZ,U,1)_U_$S(+$P(IBZ,U,12):$J($P(IBY,U,2),0,2),1:$P(IBY,U,2))_U_$P(IBZ,U,12)
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBJDB1 ;ALB/CPM - BILLING LAG TIME REPORT ; 27-DEC-96
- ;;2.0;INTEGRATED BILLING;**69,80,100,118,165**;21-MAR-94
+ ;;2.0;INTEGRATED BILLING;**69,80,100,118**;21-MAR-94
  ;
 EN ; - Option entry point.
@@ -78,8 +78,8 @@
  ;
  D ^%ZISC
-ENQ1 K IB,IBBDT,IBBN,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2
- K IBX3,IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1
- K IBCT,IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE
- K IBDR,IBH,DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3
+ENQ1 K IB,IBBDT,IBEDT,IBCK,IBN,IBN0,IBRPT,IBPAG,IBQ,IBRUN,IBX,IBX1,IBX2,IBX3
+ K IBAUTH,IBDAT,IBDFN,IBNU,IBPTF,IBPOL,IBPOL1,IBTY,IBS,IBSEL,IBSEL1,IBCT
+ K IBDIV,IBSORT,IBTL,IBCHK,IBDCHK,DFN,POP,VAUTD,ZTDESC,ZTRTN,ZTSAVE
+ K DIROUT,DTOUT,DUOUT,DIRUT,%,%ZIS,D,X,X1,X2,Y,Y1,Z,Z1,Z2,Z3
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDB11.m	(revision 636)
@@ -1,4 +1,4 @@
 IBJDB11 ;ALB/CPM - BILLING LAG TIME REPORT (COMPILE) ; 27-DEC-96
- ;;2.0;INTEGRATED BILLING;**69,100,118,165**;21-MAR-94
+ ;;2.0;INTEGRATED BILLING;**69,100,118**;21-MAR-94
  ;
 EN ; - Entry point from IBJDB1.
@@ -28,6 +28,9 @@
  .S IBTY=$S($P(IBN0,U,5)<3:"IN",1:"OP") ; Inpatient or outpatient claim?
  .;
- .;- Get date PTF transmitted.
- .S IBPTF="" I IBTY="IN" S IBPTF=$$PTF($P(IBN0,U,8)) Q:'IBPTF
+ .; - Get most recent date PTF transmitted.
+ .I IBTY="IN" D  Q:'IBPTF!('IBPTF&($P(IBAUTH,U,2)))
+ ..S IBPTF=$P(IBN0,U,8) I 'IBPTF Q
+ ..S IBPTF=$O(^DGP(45.83,"C",IBPTF,9999999),-1)\1 I IBPTF Q
+ ..S IBPTF=$P($G(^DGP(45.83,IBPTF,0)),U,2)\1
  .;
  .; - Get other claim info and build date line.
@@ -53,17 +56,12 @@
  ..; - Get most recent check out date that has not been marked as non
  ..;   billable by Claims Tracking; quit if there isn't one.
- ..I IBTY="OP" D  K IBCL,IBCL1 Q:'IBCHK
- ...D CL(IBN) ;GET LIST OF CLINICS FOR THIS BILL
+ ..I IBTY="OP" D  Q:'IBCHK
  ...S IBCHK=0,IBX1=IBX-.0001
  ...F  S IBX1=$O(^SCE("ADFN",DFN,IBX1)) Q:'IBX1!((IBX1\1)>IBX)  D
  ....S IBX2=0 F  S IBX2=$O(^SCE("ADFN",DFN,IBX1,IBX2)) Q:'IBX2  D
- .....;
- .....;CHECK TO SEE IF CLINICS MATCH
- .....S IBCL1=+$P($G(^SCE(IBX2,0)),U,4) Q:'$D(IBCL(IBCL1))
  .....I $P($G(^IBT(356,+$O(^IBT(356,"ASCE",IBX2,0)),0)),U,19) Q
- .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3,IBX3'>$P(IBAUTH,U,2)  D
- ...... S:IBX3>IBCHK IBCHK=IBX3 Q
+ .....S IBX3=$P($G(^SCE(IBX2,0)),U,7)\1 I IBX3 S IBCHK=IBX3
  ..;
- ..S X=$S(IBTY="IN":IBX1_U_+IBPTF,1:IBX_U_IBCHK)_U_IBDAT
+ ..S X=$S(IBTY="IN":IBX1_U_IBPTF,1:IBX_U_IBCHK)_U_IBDAT
  ..S IBPOL1=$S(IBPOL>+X:1,1:0) ; Policy found after treatment.
  ..;
@@ -112,6 +110,5 @@
  ..F Y=1:1 S Z=$P(IBSEL1,",",Y) Q:'Z  D
  ...I IBRPT="D" D
- ....S IBBN=$P(IBN0,U) S:IBPOL1 IBBN=IBBN_"*"
- ....S Y(Z)=IBBN_U_Y(Z),Y1(Z)=$G(Y1(Z))+1
+ ....S Y(Z)=$P(IBN0,U)_U_Y(Z)_U_$S(IBPOL1:"*",1:""),Y1(Z)=$G(Y1(Z))+1
  ....S ^TMP("IBJDB1",$J,IBDIV,IBTY,Z,$P(IBDFN,U)_"@@"_$P(IBDFN,U,9),Y1(Z))=Y(Z)
  ...E  S IBCT(IBDIV,IBTY,Z)=IBCT(IBDIV,IBTY,Z)+1,IBTL(IBDIV,IBTY,Z)=IBTL(IBDIV,IBTY,Z)+Y(Z)
@@ -147,5 +144,5 @@
  ;
 FP ; - Get first payment date, if available.
- I '$P($G(^PRCA(430,IBN,7)),U,7) G DC ; No payments made.
+ I '$P($G(^PRCA(430,IBN,7)),U,7) G CL ; No payments made.
  S (IBPAY,IBT)=0 F  S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT  D  Q:IBPAY
  .S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
@@ -154,5 +151,5 @@
  .S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
  ;
-DC ; - Get date AR closed.
+CL ; - Get date AR closed.
  S X=$$CLO^PRCAFN(IBN) I X>0 S $P(VAL,U,5)=X
  ;
@@ -170,20 +167,2 @@
  I IBSEL[(","_X_","),X1'<IBBDT,X1'>IBEDT S X2=1
 DLQ Q X2
- ;
- ;
-PTF(X) ; - Get most recent PTF transmission date.
- ;    Input: X=IEN of PTF file entry.
- ;   Output: Y=PTF date.
- N I,K,Y
- S Y=0 G:'$O(^DGP(45.83,"C",+X,0)) PTFQ
- S I=0 F  S I=$O(^DGP(45.83,"C",X,I)) Q:'I  D
- .S J=$P($G(^DGP(45.83,I,0)),U,2)\1  Q:J>$P(IBAUTH,U,2)  S:J K(J)=""
- S I=0 F  S I=$O(K(I)) Q:'I  S Y=I
- ;
-PTFQ Q Y
- ;
-CL(IBN) ; - Get the clinics for bill.
- N I,J K IBCL ; IBCL=Bill clinic array.
- S I=0 F  S I=$O(^DGCR(399,IBN,"CP",I)) Q:I=""  D
- .S J=$P($G(^DGCR(399,IBN,"CP",I,0)),U,7) S:J IBCL(J)=""
- Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS.m	(revision 636)
@@ -1,4 +1,4 @@
 IBJPS ;ALB/MAF,ARH - IBSP IB SITE PARAMETER SCREEN ;22-DEC-1995
- ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**39,52,70,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -49,5 +49,5 @@
 7 ;;1.33;1.32;1.31;1.27
 8 ;;1.29;1.3;1.18;1.28
-9 ;;1.01;1.02;1.05
+9 ;;1.01;1.02;1.05;1.04
 10 ;;2.12;2.1;2.02;2.03;2.04;2.05;2.06;2.01
 11 ;;2.08;2.09
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJPS2.m	(revision 636)
@@ -1,4 +1,4 @@
 IBJPS2 ;ALB/MAF,ARH - IBSP IB SITE PARAMETER BUILD (cont) ;22-DEC-1995
- ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349,377**;21-MAR-94;Build 23
+ ;;2.0;INTEGRATED BILLING;**39,52,115,143,51,137,161,155,320,348,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -47,4 +47,7 @@
  D LEFT(2)
  S IBLN=$$SET("Federal Tax #",$P(IBPD1,U,5),IBLN,IBLR,IBSEL)
+ ;
+ D RIGHT(3,"","")
+ S IBLN=$$SET("Remark on Each Bill",$P(IBPD1,U,4),IBLN,IBLR,IBSEL)
  ;
  D RIGHT(3,1,1) ; - Remittance/Agent Cashier Address
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTA1.m	(revision 636)
@@ -1,5 +1,5 @@
 IBJTA1 ;ALB/ARH - TPI ACTIONS ;2/14/95
- ;;2.0;INTEGRATED BILLING;**39,137,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**39,137**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 CP ; -- IBJT CHANGE PATIENT action: change patient, only available on AL screen
@@ -46,22 +46,11 @@
  ;     IBARCOMM set to indicate AR Profile screen needs to be rebuilt when it is reentered
  ;     will cause the AR screen to be rebuilt including the new information if the AR screen is already open
- N AUTHDT,MRADT,STATUS,VALMQUIT,DIR
+ N VALMQUIT,DIR
  D FULL^VALM1
- S STATUS=$P($G(^DGCR(399,IBIFN,0)),U,13)
- S AUTHDT=$P($G(^DGCR(399,IBIFN,"S")),U,10)
- S MRADT=$P($G(^DGCR(399,IBIFN,"S")),U,7)
- ; if claim status is "NOT REVIEWED" or claim status is "CANCELLED" with neither MRA request date
- ; nor Authorization date present, display an error and bail out.
- I STATUS=1!(STATUS=7&(MRADT="")&(AUTHDT="")) D  G ARCAQ
- .S DIR(0)="EA",DIR("A",1)="A comment can not be added for an incomplete or cancelled while incomplete claim.",DIR("A")="Press RETURN to continue: " D ^DIR K DIR
- ; if claim status is "REQUEST MRA" or claim status is "CANCELLED" with MRA request date present,
- ; but no Authorization date, enter MRA comments.
- I STATUS=2!(STATUS=7&(MRADT'="")&(AUTHDT="")) D:$G(IBIFN) CMNT^IBCECOB6 G ARCAR
- ; otherwise, enter AR comments.
+ I $P($G(^DGCR(399,IBIFN,0)),U,13)=2 D  G ARCAQ
+ . S DIR(0)="EA",DIR("A",1)="A/R comments cannot be added for a bill awaiting an MRA request",DIR("A")="Press RETURN to continue: " D ^DIR K DIR
  D ADJUST^RCJIBFN3(IBIFN)
  I $D(^TMP("IBJTTA",$J)) S IBARCOMM=1
- K ^TMP("IBJTTC",$J)
-ARCAR ; rebuild comments screen
- D BLD^IBJTTC,HDR^IBJTTC
+ K ^TMP("IBJTTC",$J) D BLD^IBJTTC,HDR^IBJTTC
 ARCAQ S VALMBCK="R",VALMBG=1
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTBA.m	(revision 636)
@@ -1,4 +1,4 @@
 IBJTBA ;ALB/ARH - TPI BILL CHARGE INFO SCREEN ;01-MAR-1995
- ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**39,80,51,137,135,309,349**;21-MAR-94;Build 46
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -157,5 +157,5 @@
  D SET^IBCSC5B(IBIFN,.IBARRAY)
  I $D(IBARRAY) D
- . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($$PINB^IBCSC5B(+IBARRAY(Z0,Z1)),1,39)
+ . S (Z,Z0)=0 F  S Z0=$O(IBARRAY(Z0)) Q:Z0=""  S Z1=0 F  S Z1=$O(IBARRAY(Z0,Z1)) Q:'Z1  S Z=Z+1,IBXDATA(Z)=$$DAT1^IBOUTL(Z0)_U_$E($P($$PIN^IBCSC5B(Z1),U,2),1,39)
  S IBD=$$SET("",IBLN)
  S IBD="PROSTHETIC REFILLS: (For TPJI display only)"
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTCA2.m	(revision 636)
@@ -1,5 +1,23 @@
-IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;16-FEB-1995
- ;;2.0;INTEGRATED BILLING;**39,80,155,320**;21-MAR-94
+IBJTCA2 ;ALB/ARH - TPI CLAIMS INFO BUILD (CONT) ;7:39 PM  30 Jan 2008
+ ;;2.0;INTEGRATED BILLING;**39,80,155,320,VWEHR1**;WorldVistA 30-Jan-08
  ;;Per VHA Directive 10-93-142, this routine should not be modified.
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
 CONT ; Continuation of Claim Information Screen Build
@@ -28,5 +46,5 @@
  I +$P(IBDS,U,17) S IBT="Cancelled: ",IBD=$$EXT(IBDS,17,18) S IBLN=$$SET(IBT,IBD,IBLN,IBLR)
  ;
- ; Patch 320 - added bill cloning history to TPJI report. 
+ ; Patch 320 - added bill cloning history to TPJI report.
  N IBCCR,IBCURR,IBNEXT,IBBCH,IBINDENT
  S IBINDENT=0
@@ -47,5 +65,12 @@
  ; now go backwards for claim cloning history all the way back
  S IBBCH=IBCURR
- F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ ;
+ ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ ;
+ ;F  S IBBCH=$Q(@IBBCH,-1) Q:IBBCH=""  D
+ F  S IBBCH=$$Q^VWUTIL($NA(@IBBCH),-1) Q:IBBCH=""  D
+ . ;
+ . ;END CHANGE
+ . ;
  . N IBX S IBX=@IBBCH
  . S IBT="Copied: " I IBINDENT S IBT="                  "_IBT
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTRA1.m	(revision 636)
@@ -1,4 +1,4 @@
 IBJTRA1 ;ALB/AAS,ARH - TPI CT INSURANCE COMMUNICATIONS BUILD ; 4/1/95
- ;;2.0;INTEGRATED BILLING;**39,91,347,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**39,91,347**;21-MAR-94;Build 24
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -61,5 +61,5 @@
  S X=$$EXSET^IBJU1(IBTYP,356,.18)
  I IBTYP=2 S X=X_" of "_$P($G(^DIC(40.7,+$$SCE^IBSDU(+$P(IBTRND,U,4),3),0)),U,1)
- I IBTYP=3 S X=X_" of "_$P($$PIN^IBCSC5B(+$P(IBTRND,U,9)),U,2)
+ I IBTYP=3 S Y=+$P($G(^RMPR(660,+$P(IBTRND,U,9),0)),U,6),X=X_" of "_$$EXSET^IBJU1(Y,660,4)
  I IBTYP=4 S X=X_" of "_$$FILE^IBRXUTL(+$P(IBTRND,U,8),.01)
  S X=X_" on "_$$DAT1^IBOUTL($P(IBTRND,U,6),"2P")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJTTC.m	(revision 636)
@@ -1,5 +1,5 @@
 IBJTTC ;ALB/ARH - TPI AR COMMENT HISTORY ; 06-MAR-1995
- ;;2.0;INTEGRATED BILLING;**39,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;Version 2.0 ; INTEGRATED BILLING ;**39**; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ; AR Profile of Comments:  This screen prints the following Comments:
@@ -34,5 +34,5 @@
  ;
 BLD ;
- N CMLN,CMSTR,X,IBCNT,IBZ,IB0,IBI,IBX,IBD,IBDATE,IBDUZ,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
+ N X,IBCNT,IBI,IBX,IBD,IBRCT5,IBLN,IBSTR,IBK,IBJ,DIWL,DIWR,DIWF,COM
  ;
  S VALMCNT=0,IBLN=0
@@ -71,29 +71,4 @@
  . K ^UTILITY($J,"W")
  K ^TMP("RCJIB",$J),^UTILITY($J,"W")
- ; MRA comments
- ; check if we have any comments to display
- I $D(^DGCR(399,IBIFN,"TXC","B")) D
- .S IBLN=$$SET("",IBLN)
- .S IBSTR="",IBSTR=$$SETLN("MRA REQUEST CLAIM COMMENTS",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
- .S IBSTR="",IBSTR=$$SETLN("--------------------------",IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN)
- .; loop through all available comments
- .S IBDATE="" F  S IBDATE=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE),-1) Q:IBDATE=""  D
- ..S IBZ=$O(^DGCR(399,IBIFN,"TXC","B",IBDATE,"")),IB0=^DGCR(399,IBIFN,"TXC",IBZ,0),IBDUZ=$P(IB0,U,2)
- ..S IBLN=$$SET("",IBLN)
- ..S IBSTR=""
- ..S IBSTR=$$SETLN($$FMTE^XLFDT(IBDATE,"2Z"),IBSTR,14,8)
- ..S IBSTR=$$SETLN($J("Entered by "_$$GET1^DIQ(200,IBDUZ,.01),54),IBSTR,25,54)
- ..S IBLN=$$SET(IBSTR,IBLN),IBSTR=""
- ..; loop through comment lines
- ..S CMLN=0 F  S CMLN=$O(^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN)) Q:CMLN=""  D
- ...S X=^DGCR(399,IBIFN,"TXC",IBZ,1,CMLN,0) I X'="" S DIWL=1,DIWR=54,DIWF=""  D ^DIWP
- ...Q
- ..I $D(^UTILITY($J,"W")) S IBK=0 F  S IBK=$O(^UTILITY($J,"W",1,IBK)) Q:'IBK  D
- ...S CMSTR=$G(^UTILITY($J,"W",1,IBK,0)) S IBSTR=$$SETLN(CMSTR,IBSTR,25,54),IBLN=$$SET(IBSTR,IBLN),IBSTR=""
- ...Q
- ..K ^UTILITY($J,"W")
- ..Q
- .D CLEAN^DILF
- .Q
  ;
  I IBLN=0 S IBLN=$$SET("",IBLN),IBLN=$$SET("No Comment Transactions Exist For This Account.",IBLN)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN3.m	(revision 636)
@@ -1,5 +1,5 @@
 IBRFN3 ;ALB/ARH - PASS BILL/CLAIM TO AR ;3/18/96
- ;;2.0;INTEGRATED BILLING;**61,133,210,309,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**61,133,210,309**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
  ;  Returns information on the bill passed in,  all data returned in external format, for AR's RC project
@@ -122,5 +122,5 @@
  .. S IBX=IBTMP(IBI,IBK)
  .. S IBJ=IBJ+1,ARRAY("PRD")=IBJ
- .. S ARRAY("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI
+ .. S ARRAY("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI
  ;
 CC ; condition related to employment, auto accident (place), other accident
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBRFN4.m	(revision 636)
@@ -1,5 +1,5 @@
 IBRFN4 ;ALB/TMK - Supported functions for AR/IB DATA EXTRACT ;15-FEB-2005
- ;;2.0;INTEGRATED BILLING;**301,305,389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**301,305**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 IBAREXT(IBIFN,IBD) ; Returns data for claim IBIFN for IB/AR Extract
@@ -51,5 +51,5 @@
  .. S IBX=IBTMP(IBI,IBK)
  .. S IBJ=IBJ+1
- .. S IBD("PRD",IBJ)=$$PINB^IBCSC5B(+IBX)_U_IBI_U_+IBTMP
+ .. S IBD("PRD",IBJ)=$P($$PIN^IBCSC5B(IBK),U,2)_U_IBI_U_+IBTMP
  ;
  S Z=" ",IBD("IN")="",DFN=+$P(IB(0),U,2)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI1.m	(revision 636)
@@ -1,5 +1,5 @@
 IBTOBI1 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
- ;;2.0;INTEGRATED BILLING;**276,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 % ;
@@ -46,24 +46,20 @@
  I ($Y+8)>IOSL D HDR^IBTOBI Q:IBQUIT
 BI1 W !,"  Billing Information "
- N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBLN,IBECME
+ N IBDGCR,IBDGCRU1,IBDGCRU,IBAMNT,IBD,I,IBIFN,IBADD,IBECME
  S IBIFN=+$P(IBTRND,"^",11)
  S IBDGCR=$G(^DGCR(399,IBIFN,0)),IBDGCRU1=$G(^("U1")),IBDGCRU=$G(^("U"))
  S IBECME=$P($P($G(^DGCR(399,IBIFN,"M1")),U,8),";")
  S IBAMNT=$$BILLD^IBTRED1(IBTRN)
- S IBLN=0
- S IBLN=IBLN+1,IBD(IBLN,1)="  Initial Bill: "_$P(IBDGCR,U,1)
+ S IBADD=0
+ S IBD(1,1)="  Initial Bill: "_$P(IBDGCR,"^")
  I IBECME D
- . S IBD(IBLN,1)=IBD(IBLN,1)_"e"
- . S IBLN=IBLN+1,IBD(IBLN,1)="   ECME Number: "_IBECME
- S IBLN=IBLN+1,IBD(IBLN,1)="   Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,U,13)),1,14)
- S IBLN=IBLN+1,IBD(IBLN,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8)
- S IBLN=IBLN+1,IBD(IBLN,1)="   Amount Paid: $ "_$J($P(IBAMNT,"^",2),8)
+ . S IBADD=1
+ . S IBD(1,1)=IBD(1,1)_"e"
+ . S IBD(2,1)="   ECME Number: "_IBECME
+ S IBD(2+IBADD,1)="   Bill Status: "_$E($$EXPAND^IBTRE(399,.13,$P(IBDGCR,"^",13)),1,14)
+ S IBD(3+IBADD,1)=" Total Charges: $ "_$J($P(IBAMNT,"^"),8)
+ S IBD(4+IBADD,1)="   Amount Paid: $ "_$J($P(IBAMNT,"^",2),8)
  ;
- I $P(IBTRND,U,19) D
- . S IBLN=IBLN+1,IBD(IBLN,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,U,19))
- . S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8)
- . Q
- ;
- I '$P(IBTRND,U,19),$L($P(IBTRND1,U,8))>0 S IBLN=IBLN+1,IBD(IBLN,1)="Additional Comment: "_$P(IBTRND1,U,8)
+ I $P(IBTRND,"^",19) S IBD(5,1)="Reason Not Billable: "_$$EXPAND^IBTRE(356,.19,$P(IBTRND,"^",19)),IBD(6,1)="Additional Comment: "_$P(IBTRND1,"^",8)
  ;
  S IBD(1,2)="Estimated Recv (Pri): $ "_$J($P(IBTRND,"^",21),8)
@@ -71,5 +67,5 @@
  S IBD(3,2)="Estimated Recv (ter): $ "_$J($P(IBTRND,"^",23),8)
  S IBD(4,2)="  Means Test Charges: $ "_$J($P(IBTRND,"^",28),8)
- ;
+ I $L($P($G(^IBT(356,IBTRN,1)),U,8))>0 S IBD(5,1)="Additional Comment: "_$P($G(^IBT(356,IBTRN,1)),U,8)
  S I=0 F  S I=$O(IBD(I)) Q:'I  W !,$G(IBD(I,1)),?39,$E($G(IBD(I,2)),1,36)
  W:'IBQUIT !,?4,$TR($J(" ",IOM-8)," ","-")
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTOBI4.m	(revision 636)
@@ -1,4 +1,4 @@
 IBTOBI4 ;ALB/AAS - CLAIMS TRACKING BILLING INFORMATION PRINT ;27-OCT-93
- ;;2.0;INTEGRATED BILLING;**91,125,51,210,266,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**91,125,51,210,266**;21-MAR-94
  ;
 CLIN ; -- output clinical information
@@ -94,5 +94,5 @@
 4 ; -- Visit region for prosthetics
  N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
- S IBD(2,1)="          Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2)
+ S IBD(2,1)="          Item: "_$G(IBRMPR(660,+IBDA,4,"E"))
  S IBD(3,1)="   Description: "_$G(IBRMPR(660,+IBDA,24,"E"))
  S IBD(4,1)="      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRED01.m	(revision 636)
@@ -1,5 +1,5 @@
 IBTRED01 ;ALB/AAS - EXPAND/EDIT CLAIMS TRACKING ENTRY - CONT; 01-JUL-1993
- ;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+ ;;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 % I '$G(IBTRN)!($G(IORVON)="") G ^IBTRED
@@ -69,5 +69,5 @@
 4 ; -- Visit region for prosthetics
  N IBDA,IBRMPR S IBDA=$P(IBTRND,"^",9) D PRODATA^IBTUTL1(IBDA)
- D SET^IBCNSP(START+2,OFFSET,"          Item: "_$P($$PIN^IBCSC5B(+IBDA),U,2))
+ D SET^IBCNSP(START+2,OFFSET,"          Item: "_$G(IBRMPR(660,+IBDA,4,"E")))
  D SET^IBCNSP(START+3,OFFSET,"   Description: "_$G(IBRMPR(660,+IBDA,24,"E")))
  D SET^IBCNSP(START+4,OFFSET,"      Quantity: "_$J($G(IBRMPR(660,+IBDA,5,"E")),$L($G(IBRMPR(660,+IBDA,14,"E")))))
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBTRKR5.m	(revision 636)
@@ -1,4 +1,4 @@
 IBTRKR5 ;ALB/AAS - CLAIMS TRACKING - ADD/TRACK PROSTHETICS ;13-JAN-94
- ;;2.0;INTEGRATED BILLING;**13,260,312,339,389**;21-MAR-94;Build 6
+ ;;2.0;INTEGRATED BILLING;**13,260,312,339**;21-MAR-94;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -82,10 +82,10 @@
  ;
  S IBDATA=$G(^RMPR(660,+IBDA,0)) Q:IBDATA=""
- S DFN=$P(IBDATA,"^",2) Q:'DFN
+ S DFN=$P(IBDATA,"^",2)
  D CL^SDCO21(DFN,IBDT,"",.IBARR)
  ;
  ; -- checks copied from rmprbil v2.0 /feb 2, 1994
  Q:'$D(^RMPR(660,+IBDA,"AM"))
- Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
+ Q:$P(^RMPR(660,+IBDA,0),U,9)=""!($P(^(0),U,12)="")!($P(^(0),U,6)="")!($P(^(0),U,14)="V")!($P(^(0),U,2)="")!($P(^(0),U,15)="*")
  ;Q:($P(^RMPR(660,+IBDA,"AM"),U,3)=2)!($P(^("AM"),U,3)=3)
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXA ; DRIVER FOR COMPILED XREFS FOR FILE #350 ; 05/25/06
+IBXA ; DRIVER FOR COMPILED XREFS FOR FILE #350 ; 10/08/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA1.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXA1 ; COMPILED XREF FOR FILE #350 ; 05/25/06
+IBXA1 ; COMPILED XREF FOR FILE #350 ; 10/08/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXA2.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXA2 ; COMPILED XREF FOR FILE #350 ; 05/25/06
+IBXA2 ; COMPILED XREF FOR FILE #350 ; 10/08/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC1.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;09/05/07
+IBXSC1 ; GENERATED FROM 'IB SCREEN1' INPUT TEMPLATE(#508), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC11.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC11 ; ;09/05/07
+IBXSC11 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC110.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC110 ; ;09/05/07
+IBXSC110 ; ;12/27/07
  S X=DE(6),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC111.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC111 ; ;09/05/07
+IBXSC111 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC112.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC112 ; ;09/05/07
+IBXSC112 ; ;12/27/07
  S X=DE(7),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC113.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC113 ; ;09/05/07
+IBXSC113 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC114.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC114 ; ;09/05/07
+IBXSC114 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -152,4 +152,6 @@
  S X=DE(3),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DE(3),DIC=DIE
+ X "K ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)"
  S X=DE(3),DIIX=2_U_DIFLD D AUDIT^DIET
 C3S S X="" G:DG(DQ)=X C3F1 K DB
@@ -162,4 +164,6 @@
  S X=DG(DQ),DIC=DIE
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
+ S X=DG(DQ),DIC=DIE
+ X "S ^DPT(""AZVWVOE"",$E($TR(X,""ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!@#$%^&*()-_=+[]{}<>,./?:;'\|""),1,30),DA)="""""
  I $D(DE(3))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
 C3F1 Q
@@ -180,5 +184,5 @@
  ;
 C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X5 S DFN=DA I X="N" D TADD^DGLOCK
@@ -196,5 +200,5 @@
  D ^IBXSC116
 C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X7 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC115.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC115.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC115.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC115 ; ;09/05/07
+IBXSC115 ; ;12/27/07
  S X=DE(7),DIC=DIE
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC116.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC116.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC116.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC116 ; ;09/05/07
+IBXSC116 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC117.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC117.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC117.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC117 ; ;09/05/07
+IBXSC117 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -57,5 +57,5 @@
 C1S S X="" G:DG(DQ)=X C1F1 K DB
 C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X1 S %DT="E" D ^%DT S X=Y K:Y<1 X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X),(X<$P(^DPT(DFN,.121),"^",7)) K X
@@ -72,5 +72,5 @@
  ;
 C2F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X2 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
@@ -91,5 +91,5 @@
  ;
 C4F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X4 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
@@ -106,5 +106,5 @@
 C6S S X="" G:DG(DQ)=X C6F1 K DB
 C6F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X6 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
@@ -118,5 +118,5 @@
 C7S S X="" G:DG(DQ)=X C7F1 K DB
 C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X7 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D TAD^DGLOCK
@@ -131,5 +131,5 @@
 C8S S X="" G:DG(DQ)=X C8F1 K DB
 C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X8 S DFN=DA D TAD^DGLOCK Q
@@ -147,5 +147,5 @@
  D SET^DGREGDD1(DA,.1216,.121,6,$E(X,1,5))
 C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=603 S DIEZRXR(2,DIXR)=""
+ F DIXR=600 S DIEZRXR(2,DIXR)=""
  Q
 X9 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D TAD^DGLOCK I $D(X) K:$L(X)>20!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC118.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC118.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC118.m	(revision 636)
@@ -1,5 +1,5 @@
-IBXSC118 ; ;09/05/07
+IBXSC118 ; ;12/27/07
  ;;
-1 N X,X1,X2 S DIXR=603 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=600 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  D
  . D TEMP^DGDDDTTM
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC12.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC12 ; ;09/05/07
+IBXSC12 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,.01,",DIC=DIE,DP=2.01,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.01,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC13.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC13 ; ;09/05/07
+IBXSC13 ; ;12/27/07
  S X=DE(12),DIC=DIE
  S DFN=DA D EN^DGMTCOR K DGMTCOR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC14.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC14 ; ;09/05/07
+IBXSC14 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S DFN=DA D EN^DGMTCOR K DGMTCOR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC15.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC15 ; ;09/05/07
+IBXSC15 ; ;12/27/07
  S X=DE(13),DIC=DIE
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC16.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC16 ; ;09/05/07
+IBXSC16 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC17.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC17 ; ;09/05/07
+IBXSC17 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC18.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC18 ; ;09/05/07
+IBXSC18 ; ;12/27/07
  S X=DE(5),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC19.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC19 ; ;09/05/07
+IBXSC19 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC3.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;02/03/08
+IBXSC3 ; GENERATED FROM 'IB SCREEN3' INPUT TEMPLATE(#574), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC31.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC31 ; ;02/03/08
+IBXSC31 ; ;12/27/07
  S X=DE(22),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,112,1,1,2.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC32.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC32 ; ;02/03/08
+IBXSC32 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC33.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC33 ; ;02/03/08
+IBXSC33 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
@@ -155,5 +155,5 @@
 X14 I '$$SUPPPT^IBCEP7B(DA,1) S Y="@3212"
  Q
-15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
+15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
  S DE(DW)="C15^IBXSC33"
  S Y="@"
@@ -166,5 +166,5 @@
  ;
 C15F1 Q
-X15 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X15 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC34.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC34 ; ;02/03/08
+IBXSC34 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC35.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC35 ; ;02/03/08
+IBXSC35 ; ;12/27/07
  S X=DE(15),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(399,122,1,1,2.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC36.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC36 ; ;02/03/08
+IBXSC36 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
@@ -50,5 +50,5 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC36",DQ=1
-1 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
+1 S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
  S DE(DW)="C1^IBXSC36"
  S Y="@"
@@ -62,5 +62,5 @@
  ;
 C1F1 Q
-X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X1 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
@@ -82,5 +82,5 @@
  Q
 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
-7 S DW="M1;2",DV="FX",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
+7 S DW="M1;2",DV="F",DU="",DLB="PRIMARY PROVIDER #",DIFLD=122
  S DE(DW)="C7^IBXSC36"
  S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
@@ -94,5 +94,5 @@
  ;
 C7F1 Q
-X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X7 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
@@ -132,5 +132,5 @@
 X18 I '$$SUPPPT^IBCEP7B(DA,2) S Y="@3222"
  Q
-19 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
+19 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
  S DE(DW)="C19^IBXSC36"
  S Y="@"
@@ -144,5 +144,5 @@
  ;
 C19F1 Q
-X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X19 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC37.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC37 ; ;02/03/08
+IBXSC37 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
@@ -50,5 +50,5 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC37",DQ=1
-1 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
+1 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
  S DE(DW)="C1^IBXSC37"
  S Y="@"
@@ -62,5 +62,5 @@
  ;
 C1F1 Q
-X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X1 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
@@ -82,5 +82,5 @@
  Q
 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
-7 S DW="M1;3",DV="FX",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
+7 S DW="M1;3",DV="F",DU="",DLB="SECONDARY PROVIDER #",DIFLD=123
  S DE(DW)="C7^IBXSC37"
  S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
@@ -94,5 +94,5 @@
  ;
 C7F1 Q
-X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X7 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
@@ -132,5 +132,5 @@
 X18 I '$$SUPPPT^IBCEP7B(DA,3) S Y="@3232"
  Q
-19 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
+19 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
  S DE(DW)="C19^IBXSC37"
  S Y="@"
@@ -144,5 +144,5 @@
  ;
 C19F1 Q
-X19 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X19 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC38.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC38 ; ;02/03/08
+IBXSC38 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
@@ -51,5 +51,5 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC38",DQ=1
-1 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
+1 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
  S DE(DW)="C1^IBXSC38"
  S Y="@"
@@ -63,5 +63,5 @@
  ;
 C1F1 Q
-X1 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X1 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
@@ -83,5 +83,5 @@
  Q
 6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 G A
-7 S DW="M1;4",DV="FX",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
+7 S DW="M1;4",DV="F",DU="",DLB="TERTIARY PROVIDER #",DIFLD=124
  S DE(DW)="C7^IBXSC38"
  S X="IBPSID" Q:X  Q:$NA(@X)[U  S X=$G(@X)
@@ -95,5 +95,5 @@
  ;
 C7F1 Q
-X7 K:$L(X)>13!($L(X)<3)!($TR(X," ")="") X
+X7 K:$L(X)>13!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC39.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC39 ; ;02/03/08
+IBXSC39 ; ;12/27/07
  ;;
 1 N X,X1,X2 S DIXR=139 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC4.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;02/03/08
+IBXSC4 ; GENERATED FROM 'IB SCREEN4' INPUT TEMPLATE(#510), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
@@ -164,5 +164,5 @@
  Q
 30 S D=0 K DE(1) ;47
- S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
+ S DIFLD=47,DGO="^IBXSC44",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
  S DU="DGCR(399.1,"
  G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M30
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC41.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC41 ; ;02/03/08
+IBXSC41 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OT"",",DIC=DIE,DP=399.048,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OT",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC42.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC42 ; ;02/03/08
+IBXSC42 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))=""
@@ -83,7 +83,7 @@
 X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@455"
  Q
-8 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04
+8 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04
  G RE
-X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X
+X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC43.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC43 ; ;02/03/08
+IBXSC43 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC44.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC44 ; ;02/03/08
+IBXSC44 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))=""
@@ -50,6 +50,6 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC44",DQ=1+D G B
-1 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01
- S DE(DW)="C1^IBXSC44",DE(DW,"INDEX")=1
+1 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01
+ S DE(DW)="C1^IBXSC44"
  S DU="DGCR(399.1,"
  G RE:'D S DQ=2 G 2
@@ -60,22 +60,11 @@
  S X=DG(DQ),DIC=DIE
  S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
-C1F1 N X,X1,X2 S DIXR=723 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
- K X M X=X2 D
- . N DIEXARR M DIEXARR=X S DIEZCOND=1
- . S X=$$COND^IBCVC(.DA,X1(1),X2(1))
- . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
- . D REMOVE^IBCVC(.DA)
- G C1F2
-C1X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1))
- S X=$G(X(1))
- Q
-C1F2 Q
-X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+C1F1 Q
+X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
  Q
  ;
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02
+2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02
  G RE
-X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X
+X2 K:$L(X)>9!($L(X)<1) X
  I $D(X),X'?.ANP K X
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC5.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;02/03/08
+IBXSC5 ; GENERATED FROM 'IB SCREEN5' INPUT TEMPLATE(#511), FILE 399;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
@@ -155,5 +155,5 @@
  Q
 27 S D=0 K DE(1) ;47
- S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'X",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
+ S DIFLD=47,DGO="^IBXSC54",DC="2^399.047PA^CV^",DV="399.047M*P399.1'",DW="0;1",DOW="VALUE CODE",DLB="Select "_DOW S:D DC=DC_D
  S DU="DGCR(399.1,"
  G RE:D I $D(DSC(399.047))#2,$P(DSC(399.047),"I $D(^UTILITY(",1)="" X DSC(399.047) S D=$O(^(0)) S:D="" D=-1 G M27
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC51.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC51 ; ;02/03/08
+IBXSC51 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC52.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC52 ; ;02/03/08
+IBXSC52 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OC"",",DIC=DIE,DP=399.041,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OC",DA,""))=""
@@ -83,7 +83,7 @@
 X7 I '$P(^DGCR(399.1,+^DGCR(399,DA(1),"OC",DA,0),0),U,10) S Y="@555"
  Q
-8 S DW="0;4",DV="RDX",DU="",DLB="END DATE",DIFLD=.04
+8 S DW="0;4",DV="D",DU="",DLB="END DATE",DIFLD=.04
  G RE
-X8 S %DT="EX" D ^%DT S X=Y K:X<1 X I $D(X),X<$P($G(^DGCR(399,DA(1),"OC",DA,0)),U,2) K X
+X8 S %DT="EX" D ^%DT S X=Y K:Y<1 X
  Q
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC53.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC53 ; ;02/03/08
+IBXSC53 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""CC"",",DIC=DIE,DP=399.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CC",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC54.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC54 ; ;02/03/08
+IBXSC54 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""CV"",",DIC=DIE,DP=399.047,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"CV",DA,""))=""
@@ -50,6 +50,6 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="IBXSC54",DQ=1+D G B
-1 S DW="0;1",DV="M*P399.1'X",DU="",DLB="VALUE CODE",DIFLD=.01
- S DE(DW)="C1^IBXSC54",DE(DW,"INDEX")=1
+1 S DW="0;1",DV="M*P399.1'",DU="",DLB="VALUE CODE",DIFLD=.01
+ S DE(DW)="C1^IBXSC54"
  S DU="DGCR(399.1,"
  G RE:'D S DQ=2 G 2
@@ -60,22 +60,11 @@
  S X=DG(DQ),DIC=DIE
  S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
-C1F1 N X,X1,X2 S DIXR=723 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
- K X M X=X2 D
- . N DIEXARR M DIEXARR=X S DIEZCOND=1
- . S X=$$COND^IBCVC(.DA,X1(1),X2(1))
- . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND
- . D REMOVE^IBCVC(.DA)
- G C1F2
-C1X1(DION) K X
- S X(1)=$G(@DIEZTMP@("V",399.047,DIIENS,.01,DION),$P($G(^DGCR(399,DA(1),"CV",DA,0)),U,1))
- S X=$G(X(1))
- Q
-C1F2 Q
-X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11),$$ALLOWVC^IBCVC(DA(1),+Y)" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+C1F1 Q
+X1 S DIC("S")="I +$P($G(^DGCR(399.1,+Y,0)),U,11)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
  Q
  ;
-2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="FX",DU="",DLB="VALUE",DIFLD=.02
+2 D:$D(DG)>9 F^DIE17,DE S DQ=2,DW="0;2",DV="F",DU="",DLB="VALUE",DIFLD=.02
  G RE
-X2 K:$L(X)>10!($L(X)<1)!'$$FORMCHK^IBCVC(X,.DA) X
+X2 K:$L(X)>9!($L(X)<1) X
  I $D(X),X'?.ANP K X
  Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC6.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;02/03/08
+IBXSC6 ; GENERATED FROM 'IB SCREEN6' INPUT TEMPLATE(#512), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC61.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC61 ; ;02/03/08
+IBXSC61 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC610.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC610 ; ;02/03/08
+IBXSC610 ; ;12/27/07
  S X=DE(22),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU-X X ^DD(399,220,1,1,2.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC611.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC611 ; ;02/03/08
+IBXSC611 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC612.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC612 ; ;02/03/08
+IBXSC612 ; ;12/27/07
  S X=DE(12),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC62.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC62 ; ;02/03/08
+IBXSC62 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC63.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC63 ; ;02/03/08
+IBXSC63 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC64.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC64 ; ;02/03/08
+IBXSC64 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC65.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC65 ; ;02/03/08
+IBXSC65 ; ;12/27/07
  S X=DE(23),DIC=DIE
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC66.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC66 ; ;02/03/08
+IBXSC66 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC67.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC67 ; ;02/03/08
+IBXSC67 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC68.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC68 ; ;02/03/08
+IBXSC68 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC69.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC69 ; ;02/03/08
+IBXSC69 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC7.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;07/22/08
+IBXSC7 ; GENERATED FROM 'IB SCREEN7' INPUT TEMPLATE(#513), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC71.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC71 ; ;07/22/08
+IBXSC71 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""OP"",",DIC=DIE,DP=399.043,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"OP",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC710.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC710 ; ;07/22/08
+IBXSC710 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC711.m	(revision 636)
@@ -1,5 +1,5 @@
-IBXSC711 ; ;07/22/08
- S X=DE(12),DIC=DIE
+IBXSC711 ; ;12/27/07
+ S X=DE(11),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399.042,.1,1,1,2.4)
- S X=DE(12),DIC=DIE
+ S X=DE(11),DIC=DIE
  X ^DD(399.042,.1,1,2,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"RC",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"RC",DIV(1),0)),DIV=X S $P(^(0),U,15)=DIV,DIH=399.042,DIG=.15 D ^DICR
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC712.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC712 ; ;07/22/08
+IBXSC712 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC72.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC72 ; ;07/22/08
+IBXSC72 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC73.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC73 ; ;07/22/08
+IBXSC73 ; ;12/27/07
  S X=DE(24),DIC=DIE
  ;
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC74.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC74 ; ;07/22/08
+IBXSC74 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC75.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC75 ; ;07/22/08
+IBXSC75 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC76.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC76 ; ;07/22/08
+IBXSC76 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC77.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC77 ; ;07/22/08
+IBXSC77 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC78.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC78 ; ;07/22/08
+IBXSC78 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC79.m	(revision 636)
@@ -1,7 +1,7 @@
-IBXSC79 ; ;07/22/08
+IBXSC79 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""RC"",",DIC=DIE,DP=399.042,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"RC",DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(7)=% S %=$P(%Z,U,7) S:%]"" DE(9)=%
- I  S %=$P(%Z,U,9) S:%]"" DE(6)=% S %=$P(%Z,U,10) S:%]"" DE(12)=% S %=$P(%Z,U,12) S:%]"" DE(13)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(1)=% S %=$P(%Z,U,2) S:%]"" DE(2)=% S %=$P(%Z,U,3) S:%]"" DE(3)=% S %=$P(%Z,U,4) S:%]"" DE(4)=% S %=$P(%Z,U,5) S:%]"" DE(5)=% S %=$P(%Z,U,6) S:%]"" DE(6)=% S %=$P(%Z,U,7) S:%]"" DE(8)=%
+ I  S %=$P(%Z,U,10) S:%]"" DE(11)=% S %=$P(%Z,U,12) S:%]"" DE(12)=%
  K %Z Q
  ;
@@ -131,80 +131,75 @@
  Q
  ;
-6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;9",DV="NJ8,2",DU="",DLB="NON-COVERED CHARGE",DIFLD=.09
- G RE
-X6 S:X["$" X=$P(X,"$",2) K:X'?.N.1".".2N!(X>99999)!(X<0)!(X?.E1"."3.N) X
- Q
- ;
-7 S DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06
- S DE(DW)="C7^IBXSC79"
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;6",DV="*P81'",DU="",DLB="PROCEDURE",DIFLD=.06
+ S DE(DW)="C6^IBXSC79"
  S DU="ICPT("
  G RE
-C7 G C7S:$D(DE(7))[0 K DB
- S X=DE(7),DIC=DIE
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
  K ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)
- S X=DE(7),DIC=DIE
+ S X=DE(6),DIC=DIE
  K ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)
-C7S S X="" G:DG(DQ)=X C7F1 K DB
+C6S S X="" G:DG(DQ)=X C6F1 K DB
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
-C7F1 Q
-X7 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
- Q
- ;
-8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X8 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758"
- Q
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;7",DV="P40.8'X",DU="",DLB="DIVISION",DIFLD=.07
- S DE(DW)="C9^IBXSC79"
+C6F1 Q
+X6 S ICPTVDT=$$BDATE^IBACSV($G(DA(1))),DIC("S")="I $$CPTACT^IBACSV(+Y,ICPTVDT)",DIC("W")="D EN^DDIOL(""   ""_$P($$CPT^IBACSV(+Y,ICPTVDT),U,2),,""?0"")" D ^DIC K DIC S DIC=$G(DIE),X=+Y K:Y<0 X
+ Q
+ ;
+7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X7 I '$P(^DGCR(399,DA(1),"RC",DA,0),U,6) S Y="@758"
+ Q
+8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;7",DV="P40.8'X",DU="",DLB="DIVISION",DIFLD=.07
+ S DE(DW)="C8^IBXSC79"
  S DU="DG(40.8,"
  S X=$$DEFDIV^IBCU7(DA(1))
  S Y=X
  G Y
-C9 G C9S:$D(DE(9))[0 K DB
- S X=DE(9),DIC=DIE
+C8 G C8S:$D(DE(8))[0 K DB
+ S X=DE(8),DIC=DIE
  K ^DGCR(399,"ASC1",+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)
- S X=DE(9),DIC=DIE
+ S X=DE(8),DIC=DIE
  K ^DGCR(399,"ASC2",DA(1),+$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)
-C9S S X="" G:DG(DQ)=X C9F1 K DB
+C8S S X="" G:DG(DQ)=X C8F1 K DB
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
  S X=DG(DQ),DIC=DIE
  I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
-C9F1 Q
-X9 Q
-10 S DQ=11 ;@758
-11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X11 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759"
- Q
-12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;10",DV="S",DU="",DLB="TYPE",DIFLD=.1
- S DE(DW)="C12^IBXSC79"
+C8F1 Q
+X8 Q
+9 S DQ=10 ;@758
+10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X10 I +$P(^DGCR(399,DA(1),"RC",DA,0),U,8) W !," AUTO ADDED CHARGE - NO CHANGE TO TYPE/COMPONENT" S Y="@759"
+ Q
+11 D:$D(DG)>9 F^DIE17,DE S DQ=11,DW="0;10",DV="S",DU="",DLB="TYPE",DIFLD=.1
+ S DE(DW)="C11^IBXSC79"
  S DU="1:INPT BS;2:OPT VST DT;3:RX;4:CPT;5:PROS;6:DRG;9:UNASSOCIATED;"
  G RE
-C12 G C12S:$D(DE(12))[0 K DB
+C11 G C11S:$D(DE(11))[0 K DB
  D ^IBXSC711
-C12S S X="" G:DG(DQ)=X C12F1 K DB
- S X=DG(DQ),DIC=DIE
- ;
- S X=DG(DQ),DIC=DIE
- ;
-C12F1 Q
+C11S S X="" G:DG(DQ)=X C11F1 K DB
+ S X=DG(DQ),DIC=DIE
+ ;
+ S X=DG(DQ),DIC=DIE
+ ;
+C11F1 Q
+X11 Q
+12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="0;12",DV="S",DU="",DLB="COMPONENT",DIFLD=.12
+ S DU="1:INSTITUTIONAL;2:PROFESSIONAL;"
+ G RE
 X12 Q
-13 D:$D(DG)>9 F^DIE17,DE S DQ=13,DW="0;12",DV="S",DU="",DLB="COMPONENT",DIFLD=.12
- S DU="1:INSTITUTIONAL;2:PROFESSIONAL;"
- G RE
-X13 Q
+13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X13 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759"
+ Q
 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X14 I $S($P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=3:0,1:$P($G(^(0)),U,10)'=4)!$P($G(^(0)),U,8) S Y="@759"
+X14 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581"
  Q
 15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X15 I $P($G(^DGCR(399,DA(1),"RC",DA,0)),U,10)=4 S Y="@7581"
+X15 S DGRVRCAL=1
  Q
 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X16 S DGRVRCAL=1
- Q
-17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X17 D LINKRX^IBCEU5(DA(1),DA)
- Q
-18 D:$D(DG)>9 F^DIE17 G ^IBXSC712
+X16 D LINKRX^IBCEU5(DA(1),DA)
+ Q
+17 D:$D(DG)>9 F^DIE17 G ^IBXSC712
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC8 ; GENERATED FROM 'IB SCREEN8' INPUT TEMPLATE(#514), FILE 399;09/05/07
+IBXSC8 ; GENERATED FROM 'IB SCREEN8' INPUT TEMPLATE(#514), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC82.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC82.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC82.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC82 ; GENERATED FROM 'IB SCREEN82' INPUT TEMPLATE(#577), FILE 399;09/05/07
+IBXSC82 ; GENERATED FROM 'IB SCREEN82' INPUT TEMPLATE(#577), FILE 399;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC821.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC821.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC821.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC821 ; ;09/05/07
+IBXSC821 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC822.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC822.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC822.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC822 ; ;09/05/07
+IBXSC822 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC823.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC823.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC823.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC823 ; ;09/05/07
+IBXSC823 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^IBA(355.93,",DIC=DIE,DP=355.93,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^IBA(355.93,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC824.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC824.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC824.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC824 ; ;09/05/07
+IBXSC824 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC825.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC825.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC825.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC825 ; ;09/05/07
+IBXSC825 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0)="SLF000" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399.0222,.05,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC826.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC826.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC826.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC826 ; ;09/05/07
+IBXSC826 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  D ATTREND^IBCU1(DA(1),DA,.13)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC827.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC827.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC827.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC827 ; ;09/05/07
+IBXSC827 ; ;12/27/07
  S X=DE(18),DIC=DIE
  D ATTREND^IBCU1(DA(1),DA,.06)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC828.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC828.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC828.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC828 ; ;09/05/07
+IBXSC828 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  D ATTREND^IBCU1(DA(1),DA,.06)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC829.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC829.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC829.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC829 ; ;09/05/07
+IBXSC829 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC8H ; GENERATED FROM 'IB SCREEN8H' INPUT TEMPLATE(#515), FILE 399;10/29/04
+IBXSC8H ; GENERATED FROM 'IB SCREEN8H' INPUT TEMPLATE(#515), FILE 399;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H1.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC8H1 ; ;10/29/04
+IBXSC8H1 ; ;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H2.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC8H2 ; ;10/29/04
+IBXSC8H2 ; ;04/08/05
  D DE G BEGIN
 DE S DIE="^IBA(355.93,",DIC=DIE,DP=355.93,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^IBA(355.93,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H3.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC8H3 ; ;10/29/04
+IBXSC8H3 ; ;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXSC8H4.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXSC8H4 ; ;10/29/04
+IBXSC8H4 ; ;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""PRV"",",DIC=DIE,DP=399.0222,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"PRV",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXST ; GENERATED FROM 'IB STATUS' INPUT TEMPLATE(#506), FILE 399;10/29/04
+IBXST ; GENERATED FROM 'IB STATUS' INPUT TEMPLATE(#506), FILE 399;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST1.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXST1 ; ;10/29/04
+IBXST1 ; ;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,D0,""D1"",",DIC=DIE,DP=399.044,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGCR(399,D0,"D1",DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST2.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXST2 ; ;10/29/04
+IBXST2 ; ;04/08/05
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST3.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXST3 ; ;10/29/04
+IBXST3 ; ;04/08/05
  S X=DE(19),DIC=DIE
  K ^DGCR(399,"ALEX",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST4.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXST4 ; ;10/29/04
+IBXST4 ; ;04/08/05
  S X=DG(DQ),DIC=DIE
  S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXST5.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXST5 ; ;10/29/04
+IBXST5 ; ;04/08/05
  D DE G BEGIN
 DE S DIE="^DGCR(399,",DIC=DIE,DP=399,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGCR(399,DA,""))=""
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 07/22/08
+IBXX ; DRIVER FOR COMPILED XREFS FOR FILE #399 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
@@ -7,7 +7,7 @@
 DI S DIKM1=0,DIKUM=0,DA(0)="",DV=0 F  S DV=$O(DA(DV)) Q:DV'>0  S DIKUM=DIKUM+1,DIKUP(DV)=DA(DV)
  S:DV="" DV=-1 S DH(1)=399,DIKUP=DA
- I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
+ I $D(DIKKS) D:DIKZ1=DH(1) ^IBXX1 S DA=DIKUP D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) KILL D:DIKZ1'=DH(1) DA D:DIKZ1'=DH(1) SET D DA Q
  I $D(DIKIL) D:DIKZ1=DH(1) ^IBXX1 S:DIKZ1=DH(1) DIKM1=1 D:DIKZ1'=DH(1) KILL S DA=DIKUP D:DIKM1>0 KIL1 D DA Q
- I $D(DIKST) D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D DA Q
+ I $D(DIKST) D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D DA Q
  I $D(DIKSAT) D SET1 D DA Q
  Q
@@ -17,5 +17,5 @@
  S DU=$E(DIK,1,$L(DIK)-1),DIKLK=$S(DIK[",":DU_")",1:DU) L +@DIKLK:10 K:'$T DIKLK
 C I @("$O("_DIK_"DA))'>0") S DA=$$C1(DA),^(0)=$P(@(DIK_"0)"),U,1,2)_U_DA_U_DCNT K DCNT L:$D(DIKLK) -@DIKLK Q
- S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX15 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
+ S (DIKY,DA)=$O(^(DA)) G C:$P($G(^(DA,0)),U)']"" S DU=1,DCNT=DCNT+1 S:DA="" (DIKY,DA)=-1 D:DIKZ1=DH(1) ^IBXX14 D:DIKZ1'=DH(1) SET D:DIKZ1'=DH(1) DA K DB(0) S DA=DIKY G C
  Q
 C1(A) Q:$P($G(@(DIK_"A,0)")),U)]"" A
@@ -24,5 +24,5 @@
 KILL S DIKILL=1,DIKZK=2
  I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX3 Q
- I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX14 Q
+ I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX4,A1^IBXX13 Q
  I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX5 Q
  I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX6 Q
@@ -33,20 +33,18 @@
  I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX11 Q
  I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX12 Q
- I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX13 Q
- I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX14 Q
+ I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX13 Q
  Q
 SET S DISET=1,DIKZK=1 K DIKPUSH
- I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX19 Q
- I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX20,A1^IBXX30 Q
- I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q
- I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q
- I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX23 Q
- I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q
- I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q
- I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q
- I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q
- I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX28 Q
- I DIKZ1=399.077,DIKUM'<1 S DIKM1=1 D A1^IBXX29 Q
- I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX30 Q
+ I DIKZ1=399.0222,DIKUM'<1 S DIKM1=1 D A1^IBXX18 Q
+ I DIKZ1=399.0304,DIKUM'<1 S DIKM1=1 D A1^IBXX19,A1^IBXX28 Q
+ I DIKZ1=399.041,DIKUM'<1 S DIKM1=1 D A1^IBXX20 Q
+ I DIKZ1=399.042,DIKUM'<1 S DIKM1=1 D A1^IBXX21 Q
+ I DIKZ1=399.043,DIKUM'<1 S DIKM1=1 D A1^IBXX22 Q
+ I DIKZ1=399.044,DIKUM'<1 S DIKM1=1 D A1^IBXX23 Q
+ I DIKZ1=399.045,DIKUM'<1 S DIKM1=1 D A1^IBXX24 Q
+ I DIKZ1=399.046,DIKUM'<1 S DIKM1=1 D A1^IBXX25 Q
+ I DIKZ1=399.047,DIKUM'<1 S DIKM1=1 D A1^IBXX26 Q
+ I DIKZ1=399.048,DIKUM'<1 S DIKM1=1 D A1^IBXX27 Q
+ I DIKZ1=399.30416,DIKUM'<2 S DIKM1=2 D A1^IBXX28 Q
  Q
 KIL1 K @(DIK_"DA)") Q:'$D(^(0))
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX1 ; COMPILED XREF FOR FILE #399 ; 07/22/08
+IBXX1 ; COMPILED XREF FOR FILE #399 ; 12/27/07
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX10.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 07/22/08
+IBXX10 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX11.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 07/22/08
+IBXX11 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX12.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 07/22/08
+IBXX12 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX13.m	(revision 636)
@@ -1,13 +1,16 @@
-IBXX13 ; COMPILED XREF FOR FILE #399.077 ; 07/22/08
+IBXX13 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07
  ; 
- S DA=0
+ S DA(2)=DA(1) S DA(1)=0 S DA=0
 A1 ;
- I $D(DIKILL) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
-0 ;
-A S DA=$O(^DGCR(399,DA(1),"TXC",DA)) I DA'>0 S DA=0 G END
+ I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
+A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"TXC",DA,0))
+B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
+2 ;
+ S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
+ S X=$P(DIKZ(0),U,2)
+ I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
  S X=$P(DIKZ(0),U,1)
- I X'="" K ^DGCR(399,DA(1),"TXC","B",$E(X,1,30),DA)
- G:'$D(DIKLM) A Q:$D(DIKILL)
-END G ^IBXX14
+ I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
+ G:'$D(DIKLM) B Q:$D(DIKILL)
+END Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m	(revision 636)
@@ -1,16 +1,157 @@
-IBXX14 ; COMPILED XREF FOR FILE #399.30416 ; 07/22/08
+IBXX14 ; COMPILED XREF FOR FILE #399 ; 12/27/07
  ; 
- S DA(2)=DA(1) S DA(1)=0 S DA=0
-A1 ;
- I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
-A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
-1 ;
-B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
-2 ;
- S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
+ S DIKZK=1
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
+ S X=$P(DIKZ(0),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
  S X=$P(DIKZ(0),U,2)
- I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
- S X=$P(DIKZ(0),U,1)
- I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
- G:'$D(DIKLM) B Q:$D(DIKILL)
-END Q
+ I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
+ S X=$P(DIKZ(0),U,3)
+ I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
+ S X=$P(DIKZ(0),U,8)
+ I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,8)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D EN^IBCU5
+ S X=$P(DIKZ(0),U,11)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
+ S X=$P(DIKZ(0),U,13)
+ I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
+ S X=$P(DIKZ(0),U,13)
+ I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,14)
+ I X'="" D BC^IBJVDEQ
+ S X=$P(DIKZ(0),U,17)
+ I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
+ S X=$P(DIKZ(0),U,19)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D ALLID^IBCEP3(DA,.19,1)
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D BILLPNS^IBCU(DA)
+ S X=$P(DIKZ(0),U,19)
+ I X'="" D ATTREND^IBCU1(DA,"","")
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,20)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
+ S X=$P(DIKZ(0),U,21)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
+ S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
+ S X=$P(DIKZ(0),U,22)
+END G ^IBXX15
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX15.m	(revision 636)
@@ -1,157 +1,135 @@
-IBXX15 ; COMPILED XREF FOR FILE #399 ; 07/22/08
+IBXX15 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
  ; 
- S DIKZK=1
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,1)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
- S X=$P(DIKZ(0),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,2)
- I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,3)
- I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,3)
- I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
- S X=$P(DIKZ(0),U,3)
- I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
- S X=$P(DIKZ(0),U,4)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,5)
- I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,5)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,6)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,7)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
- S X=$P(DIKZ(0),U,7)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
- S X=$P(DIKZ(0),U,7)
- I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,8)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
- S X=$P(DIKZ(0),U,8)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
- S X=$P(DIKZ(0),U,8)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
- S X=$P(DIKZ(0),U,8)
- I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,8)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,11)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
- S X=$P(DIKZ(0),U,11)
- I X'="" D EN^IBCU5
- S X=$P(DIKZ(0),U,11)
- I X'="" S DGRVRCAL=1
- S X=$P(DIKZ(0),U,11)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,13)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
- S X=$P(DIKZ(0),U,13)
- I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
- S X=$P(DIKZ(0),U,13)
- I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
- S X=$P(DIKZ(0),U,13)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,14)
- I X'="" D BC^IBJVDEQ
- S X=$P(DIKZ(0),U,17)
- I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,19)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
- S X=$P(DIKZ(0),U,19)
- I X'="" S DGRVRCAL=1
- S X=$P(DIKZ(0),U,19)
- I X'="" D ALLID^IBCEP3(DA,.19,1)
- S X=$P(DIKZ(0),U,19)
- I X'="" D BILLPNS^IBCU(DA)
- S X=$P(DIKZ(0),U,19)
- I X'="" D ATTREND^IBCU1(DA,"","")
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,20)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,21)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
- S X=$P(DIKZ(0),U,21)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
- S X=$P(DIKZ(0),U,21)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",1) X ^DD(399,.22,1,4,1.4)
  S X=$P(DIKZ(0),U,22)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",2) X ^DD(399,.22,1,5,1.4)
  S X=$P(DIKZ(0),U,22)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",3) X ^DD(399,.22,1,6,1.4)
  S X=$P(DIKZ(0),U,22)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,.22,1,7,1.4)
  S X=$P(DIKZ(0),U,22)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$P($$TAXDEF^IBCEP81(DIV(0)),U,2) X ^DD(399,.22,1,8,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,25)
+ I X'="" D ALLID^IBCEP3(DA,.25,1)
+ S X=$P(DIKZ(0),U,26)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,6)=DIV,DIH=399,DIG=.06 D ^DICR
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X=$P(DIKZ(0),U,27)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,1)
+ I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4)
+ S X=$P(DIKZ("S"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,7)
+ I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
+ S X=$P(DIKZ("S"),U,9)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,10)
+ I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
+ S X=$P(DIKZ("S"),U,12)
+ I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
+ S X=$P(DIKZ("S"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,16)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4)
+ S X=$P(DIKZ("S"),U,16)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
+ S DIKZ("S")=$G(^DGCR(399,DA,"S"))
+ S X=$P(DIKZ("S"),U,17)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
+ S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
+ S X=$P(DIKZ("TX"),U,2)
+ I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
+ S X=$P(DIKZ("TX"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
+ S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
+ S X=$P(DIKZ("TX"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
+ S DIKZ("C")=$G(^DGCR(399,DA,"C"))
+ S X=$P(DIKZ("C"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4)
+ S X=$P(DIKZ("M"),U,1)
 END G ^IBXX16
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX16.m	(revision 636)
@@ -1,135 +1,149 @@
-IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX16 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
  ; 
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",1) X ^DD(399,.22,1,4,1.4)
- S X=$P(DIKZ(0),U,22)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",2) X ^DD(399,.22,1,5,1.4)
- S X=$P(DIKZ(0),U,22)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,"",3) X ^DD(399,.22,1,6,1.4)
- S X=$P(DIKZ(0),U,22)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,.22,1,7,1.4)
- S X=$P(DIKZ(0),U,22)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$P($$TAXDEF^IBCEP81(DIV(0)),U,2) X ^DD(399,.22,1,8,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,25)
- I X'="" D ALLID^IBCEP3(DA,.25,1)
- S X=$P(DIKZ(0),U,26)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,6)=DIV,DIH=399,DIG=.06 D ^DICR
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X=$P(DIKZ(0),U,27)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,.27,1,1,1.4)
- S DIKZ("S")=$G(^DGCR(399,DA,"S"))
- S X=$P(DIKZ("S"),U,1)
- I X'="" S ^DGCR(399,"APD",$E(X,1,30),DA)=""
- S X=$P(DIKZ("S"),U,3)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,3,1,1,1.4)
- S X=$P(DIKZ("S"),U,3)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,3,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,3,1,2,1.4)
- S DIKZ("S")=$G(^DGCR(399,DA,"S"))
- S X=$P(DIKZ("S"),U,7)
- I X'="" S ^DGCR(399,"APM",$E(X,1,30),DA)=""
- S X=$P(DIKZ("S"),U,9)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,9,1,1,1.4)
- S X=$P(DIKZ("S"),U,9)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,9,1,2,69.2) S X=X="YES",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,9,1,2,1.4)
- S X=$P(DIKZ("S"),U,9)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y=Y(0) X:$D(^DD(399,9,2)) ^(2) S X=Y="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=3 X ^DD(399,9,1,3,1.4)
- S X=$P(DIKZ("S"),U,9)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,9,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X="" X ^DD(399,9,1,4,1.4)
- S DIKZ("S")=$G(^DGCR(399,DA,"S"))
- S X=$P(DIKZ("S"),U,10)
- I X'="" S ^DGCR(399,"APD3",$E(X,1,30),DA)=""
- S X=$P(DIKZ("S"),U,12)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,12,1,1,1.4)
- S X=$P(DIKZ("S"),U,12)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,12,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
- S X=$P(DIKZ("S"),U,12)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,12,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,13)=DIV,DIH=399,DIG=13 D ^DICR
- S X=$P(DIKZ("S"),U,12)
- I X'="" S ^DGCR(399,"AP",$E(X,1,30),DA)=""
- S DIKZ("S")=$G(^DGCR(399,DA,"S"))
- S X=$P(DIKZ("S"),U,14)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=4 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
- S X=$P(DIKZ("S"),U,14)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=DUZ S DIH=$G(^DGCR(399,DIV(0),"S")),DIV=X S $P(^("S"),U,15)=DIV,DIH=399,DIG=15 D ^DICR
- S DIKZ("S")=$G(^DGCR(399,DA,"S"))
- S X=$P(DIKZ("S"),U,16)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,17),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,16,1,1,1.4)
- S X=$P(DIKZ("S"),U,16)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$EXTERNAL^DIDU(399,16,"",Y(0))="YES" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,18),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,16,1,2,1.4)
- S DIKZ("S")=$G(^DGCR(399,DA,"S"))
- S X=$P(DIKZ("S"),U,17)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,16),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=7 X ^DD(399,17,1,1,1.4)
- S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
- S X=$P(DIKZ("TX"),U,2)
- I X'="" S ^DGCR(399,"ALEX",$E(X,1,30),DA)=""
- S X=$P(DIKZ("TX"),U,5)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,24,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,24,1,1,1.4)
- S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
- S X=$P(DIKZ("TX"),U,6)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,25,1,1,1.4)
- S X=$P(DIKZ("TX"),U,6)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,2,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=DUZ X ^DD(399,25,1,2,1.4)
- S X=$P(DIKZ("TX"),U,6)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(399,25,1,3,69.2) S X=X S X=X="",Y=X,X=Y(2),X=X&Y I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,7),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,25,1,3,1.4)
- S DIKZ("C")=$G(^DGCR(399,DA,"C"))
- S X=$P(DIKZ("C"),U,14)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,64,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$P(^ICD9(+X,0),"^",3) X ^DD(399,64,1,1,1.4)
- S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,101,1,2,1.1) X ^DD(399,101,1,2,1.4)
  S X=$P(DIKZ("M"),U,1)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,1) X ^DD(399,101,1,1,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,101,1,3,1.4)
  S X=$P(DIKZ("M"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,1) X ^DD(399,101,1,4,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,2) X ^DD(399,102,1,2,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,102,1,3,1.1) X ^DD(399,102,1,3,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=2,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,102,1,4,1.4)
+ S X=$P(DIKZ("M"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,2) X ^DD(399,102,1,5,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,3) X ^DD(399,103,1,2,1.4)
+ S X=$P(DIKZ("M"),U,3)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,3) X ^DD(399,103,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,11)
+ I X'="" D MAILIN^IBCU5
+ S X=$P(DIKZ("M"),U,11)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D IX^IBCNS2(DA,"I1")
+ S X=$P(DIKZ("M"),U,12)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,112,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,112,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(399,113,1,1,1.1) X ^DD(399,113,1,1,1.4)
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D IX^IBCNS2(DA,"I2")
+ S X=$P(DIKZ("M"),U,13)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,113,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,113,1,3,1.4)
+ S DIKZ("M")=$G(^DGCR(399,DA,"M"))
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(399,114,1,1,1.1) X ^DD(399,114,1,1,1.4)
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D IX^IBCNS2(DA,"I3")
+ S X=$P(DIKZ("M"),U,14)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,114,1,3,1.4)
+ S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4)
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" D MAILA^IBCU5
+ S X=$P(DIKZ("MP"),U,1)
+ I X'="" S DGRVRCAL=1
+ S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
+ S X=$P(DIKZ("MP"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4)
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
+ S X=$P(DIKZ("U"),U,1)
+ I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
+ S X=$P(DIKZ("U"),U,2)
+ I X'="" S DGRVRCAL=1
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,11)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
+ S DIKZ("U")=$G(^DGCR(399,DA,"U"))
+ S X=$P(DIKZ("U"),U,15)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
+ S X=$P(DIKZ("U"),U,15)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,4)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,6)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,6)
 END G ^IBXX17
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX17.m	(revision 636)
@@ -1,149 +1,52 @@
-IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX17 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
  ; 
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,101,1,2,1.1) X ^DD(399,101,1,2,1.4)
- S X=$P(DIKZ("M"),U,1)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4)
+ S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
+ S X=$P(DIKZ("U2"),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,101,1,3,1.4)
- S X=$P(DIKZ("M"),U,1)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y X ^DD(399,232,1,1,1.1) X ^DD(399,232,1,1,1.4)
+ S X=$P(DIKZ("U2"),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,1) X ^DD(399,101,1,4,1.4)
- S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X=$P(DIKZ("M"),U,2)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,1.4)
+ S X=$P(DIKZ("U2"),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,2) X ^DD(399,102,1,2,1.4)
- S X=$P(DIKZ("M"),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y X ^DD(399,102,1,3,1.1) X ^DD(399,102,1,3,1.4)
- S X=$P(DIKZ("M"),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$MCRWNR^IBEFUNC(X):$$COBN^IBCEF(DA)=2,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,102,1,4,1.4)
- S X=$P(DIKZ("M"),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,2) X ^DD(399,102,1,5,1.4)
+ .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$P($$TAXGET^IBCEP81(X),U,2) X ^DD(399,232,1,4,1.4)
+ S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
+ S X=$P(DIKZ("M1"),U,8)
+ I X'="" S ^DGCR(399,"AG",$E(X,1,30),DA)=""
+CR1 S DIXR=139
+ K X
  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X=$P(DIKZ("M"),U,3)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,X,3) X ^DD(399,103,1,2,1.4)
- S X=$P(DIKZ("M"),U,3)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV S X=$$PRVQUAL^IBCU(DA,X,3) X ^DD(399,103,1,3,1.4)
+ S X(1)=$P(DIKZ("M"),U,1)
+ S X(2)=$P(DIKZ("M"),U,2)
+ S X(3)=$P(DIKZ("M"),U,3)
+ S X(4)=$P(DIKZ("M"),U,13)
+ S X(5)=$P(DIKZ("M"),U,12)
+ S X(6)=$P(DIKZ("M"),U,14)
+ S X=$G(X(1))
+ D
+ . K X1,X2 M X1=X,X2=X
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0)
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) SETID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) SETID^IBCEP3(DA,3)
+CR2 S DIXR=430
+ K X
  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X=$P(DIKZ("M"),U,11)
- I X'="" D MAILIN^IBCU5
- S X=$P(DIKZ("M"),U,11)
- I X'="" S DGRVRCAL=1
- S X=$P(DIKZ("M"),U,12)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,112,1,1,1.1) X ^DD(399,112,1,1,1.4)
- S X=$P(DIKZ("M"),U,12)
- I X'="" D IX^IBCNS2(DA,"I1")
- S X=$P(DIKZ("M"),U,12)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,112,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,112,1,3,1.4)
- S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X=$P(DIKZ("M"),U,13)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y X ^DD(399,113,1,1,1.1) X ^DD(399,113,1,1,1.4)
- S X=$P(DIKZ("M"),U,13)
- I X'="" D IX^IBCNS2(DA,"I2")
- S X=$P(DIKZ("M"),U,13)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,113,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA,1) X ^DD(399,113,1,3,1.4)
- S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X=$P(DIKZ("M"),U,14)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y X ^DD(399,114,1,1,1.1) X ^DD(399,114,1,1,1.4)
- S X=$P(DIKZ("M"),U,14)
- I X'="" D IX^IBCNS2(DA,"I3")
- S X=$P(DIKZ("M"),U,14)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,114,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,114,1,3,1.4)
- S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
- S X=$P(DIKZ("MP"),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=$$FT^IBCU3(DA,1) X ^DD(399,135,1,2,1.4)
- S X=$P(DIKZ("MP"),U,1)
- I X'="" D MAILA^IBCU5
- S X=$P(DIKZ("MP"),U,1)
- I X'="" S DGRVRCAL=1
- S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
- S X=$P(DIKZ("MP"),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X='$$WNRBILL^IBEFUNC(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y X ^DD(399,136,1,1,1.1) X ^DD(399,136,1,1,1.4)
- S DIKZ("U")=$G(^DGCR(399,DA,"U"))
- S X=$P(DIKZ("U"),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,151,1,1,1.4)
- S X=$P(DIKZ("U"),U,1)
- I X'="" S DGRVRCAL=1
- S X=$P(DIKZ("U"),U,1)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I +$G(^DGCR(399,DA,"U1"))=0 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,151,1,3,1.4)
- S X=$P(DIKZ("U"),U,1)
- I X'="" S:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)=""
- S DIKZ("U")=$G(^DGCR(399,DA,"U"))
- S X=$P(DIKZ("U"),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$$LOS1^IBCU64(DA) X ^DD(399,152,1,1,1.4)
- S X=$P(DIKZ("U"),U,2)
- I X'="" S DGRVRCAL=1
- S DIKZ("U")=$G(^DGCR(399,DA,"U"))
- S X=$P(DIKZ("U"),U,11)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR
- S DIKZ("U")=$G(^DGCR(399,DA,"U"))
- S X=$P(DIKZ("U"),U,15)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=($P($G(^DGCR(399,DA,"U2")),U,2)=""&$$INPAT^IBCEF(DA,1)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIV X ^DD(399,165,1,1,1.4)
- S X=$P(DIKZ("U"),U,15)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399,165,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV N Z S X=$$LOS1^IBCU64(DA,.Z),X=+$G(Z) X ^DD(399,165,1,2,1.4)
- S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
- S X=$P(DIKZ("U2"),U,4)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,218,1,1,1.4)
- S X=$P(DIKZ("U2"),U,4)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,218,1,2,1.4)
- S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
- S X=$P(DIKZ("U2"),U,5)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,219,1,1,1.4)
- S X=$P(DIKZ("U2"),U,5)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,219,1,2,1.4)
- S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
- S X=$P(DIKZ("U2"),U,6)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=DIU+DIV X ^DD(399,220,1,1,1.4)
- S X=$P(DIKZ("U2"),U,6)
+ S X(1)=$P(DIKZ("M"),U,1)
+ S X(2)=$P(DIKZ("M"),U,2)
+ S X(3)=$P(DIKZ("M"),U,3)
+ S DIKZ(0)=$G(^DGCR(399,DA,0))
+ S X(4)=$P(DIKZ(0),U,2)
+ S X=$G(X(1))
+ D
+ . K X1,X2 M X1=X,X2=X
+ . N CURR S CURR=+$$COBN^IBCEF(DA) I $G(X(4)),$G(X(CURR)) S ^DGCR(399,"AE",X(4),X(CURR),DA)=""
+CR3 K X
 END G ^IBXX18
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX18.m	(revision 636)
@@ -1,52 +1,56 @@
-IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX18 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
  ; 
+ S DA(1)=DA S DA=0
+A1 ;
+ I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
+0 ;
+A S DA=$O(^DGCR(399,DA(1),"PRV",DA)) I DA'>0 S DA=0 G END
+1 ;
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X="PRIOR PAYMENT(S)" X ^DD(399,220,1,2,1.4)
- S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
- S X=$P(DIKZ("U2"),U,10)
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0),X=X S X=X'=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(399.0222,.01,1,2,1.4)
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","C",$E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" S ^DGCR(399,DA(1),"PRV","C",$$LOW^XLFSTR($E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30)),DA)=""
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,2)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y X ^DD(399,232,1,1,1.1) X ^DD(399,232,1,1,1.4)
- S X=$P(DIKZ("U2"),U,10)
+ .X ^DD(399.0222,.02,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399.0222,.02,1,1,1.4)
+ S X=$P(DIKZ(0),U,2)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$$CLIAREQ^IBCEP8A(DA) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U2")):^("U2"),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=$$CLIA^IBCEP8A(DA) X ^DD(399,232,1,3,1.4)
- S X=$P(DIKZ("U2"),U,10)
+ .X ^DD(399.0222,.02,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$EXTCR^IBCEU5(X) X ^DD(399.0222,.02,1,2,1.4)
+ S X=$P(DIKZ(0),U,2)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$P($$TAXGET^IBCEP81(X),U,2) X ^DD(399,232,1,4,1.4)
- S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
- S X=$P(DIKZ("M1"),U,8)
- I X'="" S ^DGCR(399,"AG",$E(X,1,30),DA)=""
-CR1 S DIXR=139
- K X
- S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X(1)=$P(DIKZ("M"),U,1)
- S X(2)=$P(DIKZ("M"),U,2)
- S X(3)=$P(DIKZ("M"),U,3)
- S X(4)=$P(DIKZ("M"),U,13)
- S X(5)=$P(DIKZ("M"),U,12)
- S X(6)=$P(DIKZ("M"),U,14)
- S X=$G(X(1))
- D
- . K X1,X2 M X1=X,X2=X
- . N DIKXARR M DIKXARR=X S DIKCOND=1
- . S X=$S($O(^DGCR(399,DA,"PRV",0)):1,1:0)
- . S DIKCOND=$G(X) K X M X=DIKXARR
- . Q:'DIKCOND
- . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) SETID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) SETID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) SETID^IBCEP3(DA,3)
-CR2 S DIXR=477
- K X
- S DIKZ("M")=$G(^DGCR(399,DA,"M"))
- S X(1)=$P(DIKZ("M"),U,1)
- S X(2)=$P(DIKZ("M"),U,2)
- S X(3)=$P(DIKZ("M"),U,3)
- S DIKZ(0)=$G(^DGCR(399,DA,0))
- S X(4)=$P(DIKZ(0),U,2)
- S X=$G(X(1))
- D
- . K X1,X2 M X1=X,X2=X
- . N CURR S CURR=+$$COBN^IBCEF(DA) I $G(X(4)),$G(X(CURR)) S ^DGCR(399,"AE",X(4),X(CURR),DA)=""
-CR3 K X
+ .X ^DD(399.0222,.02,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$SPEC^IBCEU(X) X ^DD(399.0222,.02,1,3,1.4)
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$P($$GETTAX^IBCEF73A(X),U,2) X ^DD(399.0222,.02,1,7,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D
+ .N DIK,DIV,DIU,DIN
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0)="SLF000" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399.0222,.05,1,1,1.4)
+ S X=$P(DIKZ(0),U,5)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.05)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S X=$P(DIKZ(0),U,6)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.06)
+ S X=$P(DIKZ(0),U,7)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.07)
+ S X=$P(DIKZ(0),U,12)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.12)
+ S X=$P(DIKZ(0),U,13)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.13)
+ S X=$P(DIKZ(0),U,14)
+ I X'="" D ATTREND^IBCU1(DA(1),DA,.14)
+ G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX19
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX19.m	(revision 636)
@@ -1,56 +1,32 @@
-IBXX19 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX19 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07
  ; 
- S DA(1)=DA S DA=0
+ S DA=0
 A1 ;
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"PRV",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"CP",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"PRV","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)=""
  S X=$P(DIKZ(0),U,1)
+ I X'="" I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP",DA,0)),$P(^(0),"^",2) S ^DGCR(399,"ASD",-$P(^(0),"^",2),+X,DA(1),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" I $D(^DGCR(399,DA(1),"CP",DA,0)),+^(0),$P($P(^(0),"^",1),";",2)="ICPT(" S ^DGCR(399,"ASD",-X,+^(0),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S ^DGCR(399,DA(1),"CP","D",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S DGRVRCAL=1
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,DA(1),"CP","ASC",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,7)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0),X=X S X=X'=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(399.0222,.01,1,2,1.4)
- S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"PRV","C",$E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30),DA)=""
- S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"PRV","C",$$LOW^XLFSTR($E($$EXTERNAL^DILFD(399.0222,.01,,X),1,30)),DA)=""
- S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
- S X=$P(DIKZ(0),U,2)
+ .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(399.0304,6,1,1,1.1) X ^DD(399.0304,6,1,1,1.4)
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
+ S X=$P(DIKZ(0),U,10)
  I X'="" D
  .N DIK,DIV,DIU,DIN
- .X ^DD(399.0222,.02,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399.0222,.02,1,1,1.4)
- S X=$P(DIKZ(0),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399.0222,.02,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$EXTCR^IBCEU5(X) X ^DD(399.0222,.02,1,2,1.4)
- S X=$P(DIKZ(0),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399.0222,.02,1,3,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=$$SPEC^IBCEU(X) X ^DD(399.0222,.02,1,3,1.4)
- S X=$P(DIKZ(0),U,2)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=$P($$GETTAX^IBCEF73A(X),U,2) X ^DD(399.0222,.02,1,7,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
- S X=$P(DIKZ(0),U,5)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X=Y(0)="SLF000" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"PRV",D1,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399.0222,.05,1,1,1.4)
- S X=$P(DIKZ(0),U,5)
- I X'="" D ATTREND^IBCU1(DA(1),DA,.05)
- S DIKZ(0)=$G(^DGCR(399,DA(1),"PRV",DA,0))
- S X=$P(DIKZ(0),U,6)
- I X'="" D ATTREND^IBCU1(DA(1),DA,.06)
- S X=$P(DIKZ(0),U,7)
- I X'="" D ATTREND^IBCU1(DA(1),DA,.07)
- S X=$P(DIKZ(0),U,12)
- I X'="" D ATTREND^IBCU1(DA(1),DA,.12)
- S X=$P(DIKZ(0),U,13)
- I X'="" D ATTREND^IBCU1(DA(1),DA,.13)
- S X=$P(DIKZ(0),U,14)
- I X'="" D ATTREND^IBCU1(DA(1),DA,.14)
+ .X ^DD(399.0304,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" X ^DD(399.0304,9,1,1,1.4)
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX20
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX2.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX2 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
  ; 
  I X'="" D
@@ -55,5 +55,5 @@
  . Q:'DIKCOND
  . D:X1(1)'=X2(1)!(X1(5)'=X2(5)) DELID^IBCEP3(DA,1) D:X1(2)'=X2(2)!(X1(4)'=X2(4)) DELID^IBCEP3(DA,2) D:X1(3)'=X2(3)!(X1(6)'=X2(6)) DELID^IBCEP3(DA,3)
-CR2 S DIXR=477
+CR2 S DIXR=430
  K X
  S DIKZ("M")=$G(^DGCR(399,DA,"M"))
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX20.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX20 ; COMPILED XREF FOR FILE #399.0304 ; 07/22/08
+IBXX20 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07
  ; 
  S DA=0
@@ -5,28 +5,9 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"CP",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"OC",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OC",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"CP","B",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,1)
- I X'="" I $P(X,";",2)="ICPT(",$D(^DGCR(399,DA(1),"CP",DA,0)),$P(^(0),"^",2) S ^DGCR(399,"ASD",-$P(^(0),"^",2),+X,DA(1),DA)=""
- S X=$P(DIKZ(0),U,2)
- I X'="" I $D(^DGCR(399,DA(1),"CP",DA,0)),+^(0),$P($P(^(0),"^",1),";",2)="ICPT(" S ^DGCR(399,"ASD",-X,+^(0),DA(1),DA)=""
- S X=$P(DIKZ(0),U,4)
- I X'="" S ^DGCR(399,DA(1),"CP","D",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,5)
- I X'="" S DGRVRCAL=1
- S X=$P(DIKZ(0),U,5)
- I X'="" S ^DGCR(399,DA(1),"CP","ASC",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,7)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y X ^DD(399.0304,6,1,1,1.1) X ^DD(399.0304,6,1,1,1.4)
- S DIKZ(0)=$G(^DGCR(399,DA(1),"CP",DA,0))
- S X=$P(DIKZ(0),U,10)
- I X'="" D
- .N DIK,DIV,DIU,DIN
- .X ^DD(399.0304,9,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"CP",D1,0)):^(0),1:"") S X=$P(Y(1),U,16),X=X S DIU=X K Y S X="" X ^DD(399.0304,9,1,1,1.4)
+ I X'="" S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX21
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX21.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX21 ; COMPILED XREF FOR FILE #399.041 ; 07/22/08
+IBXX21 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07
  ; 
  S DA=0
@@ -5,9 +5,29 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"OC",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"RC",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"OC",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"OC","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,1)
+ I X'="" I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" D 21^IBCU2
+ S X=$P(DIKZ(0),U,3)
+ I X'="" D 31^IBCU2
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S DGXRF=1 D TC^IBCU2 K DGXRF
+ S X=$P(DIKZ(0),U,5)
+ I X'="" S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)=""
+ S X=$P(DIKZ(0),U,6)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,6)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
+ S X=$P(DIKZ(0),U,7)
+ I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
+ S X=$P(DIKZ(0),U,15)
+ I X'="" S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX22
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX22.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX22 ; COMPILED XREF FOR FILE #399.042 ; 07/22/08
+IBXX22 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07
  ; 
  S DA=0
@@ -5,29 +5,11 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"RC",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"OP",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"RC",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OP",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"RC","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,"AOPV",$P(^DGCR(399,DA(1),0),U,2),$E(X,1,30),DA(1))=""
  S X=$P(DIKZ(0),U,1)
- I X'="" I $P(^DGCR(399,DA(1),"RC",DA,0),U,5) S ^DGCR(399,DA(1),"RC","ABS",$P(^DGCR(399,DA(1),"RC",DA,0),U,5),$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,2)
- I X'="" D 21^IBCU2
- S X=$P(DIKZ(0),U,3)
- I X'="" D 31^IBCU2
- S X=$P(DIKZ(0),U,4)
- I X'="" S DGXRF=1 D TC^IBCU2 K DGXRF
- S X=$P(DIKZ(0),U,5)
- I X'="" S ^DGCR(399,DA(1),"RC","ABS",$E(X,1,30),+^DGCR(399,DA(1),"RC",DA,0),DA)=""
- S X=$P(DIKZ(0),U,6)
- I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$E(X,1,30),DA(1),DA)=""
- S X=$P(DIKZ(0),U,6)
- I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,7)
- I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC1",$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA(1),DA)=""
- S X=$P(DIKZ(0),U,7)
- I X'="" I $$RC^IBEFUNC1(DA(1),DA) S ^DGCR(399,"ASC2",DA(1),$P(^DGCR(399,DA(1),"RC",DA,0),U,6),DA)=""
- S X=$P(DIKZ(0),U,15)
- I X'="" S ^DGCR(399,DA(1),"RC","ACP",$E(X,1,30),DA)=""
+ I X'="" S DGRVRCAL=1
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX23
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX23.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX23 ; COMPILED XREF FOR FILE #399.043 ; 07/22/08
+IBXX23 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07
  ; 
  S DA=0
@@ -5,11 +5,9 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"OP",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"D1",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"OP",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"D1",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,"AOPV",$P(^DGCR(399,DA(1),0),U,2),$E(X,1,30),DA(1))=""
- S X=$P(DIKZ(0),U,1)
- I X'="" S DGRVRCAL=1
+ I X'="" S ^DGCR(399,DA(1),"D1","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX24
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX24.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX24 ; COMPILED XREF FOR FILE #399.044 ; 07/22/08
+IBXX24 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07
  ; 
  S DA=0
@@ -5,9 +5,9 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"D1",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"D2",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"D1",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"D2",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"D1","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"D2","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX25
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX25.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX25 ; COMPILED XREF FOR FILE #399.045 ; 07/22/08
+IBXX25 ; COMPILED XREF FOR FILE #399.046 ; 12/27/07
  ; 
  S DA=0
@@ -5,9 +5,11 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"D2",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"R",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"D2",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"R",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"D2","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"R","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,4)
+ I X'="" S ^DGCR(399,DA(1),"R","AC",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX26
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX26.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX26 ; COMPILED XREF FOR FILE #399.046 ; 07/22/08
+IBXX26 ; COMPILED XREF FOR FILE #399.047 ; 12/27/07
  ; 
  S DA=0
@@ -5,11 +5,9 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"R",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"CV",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"R",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"CV",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"R","B",$E(X,1,30),DA)=""
- S X=$P(DIKZ(0),U,4)
- I X'="" S ^DGCR(399,DA(1),"R","AC",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX27
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX27.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX27 ; COMPILED XREF FOR FILE #399.047 ; 07/22/08
+IBXX27 ; COMPILED XREF FOR FILE #399.048 ; 12/27/07
  ; 
  S DA=0
@@ -5,9 +5,9 @@
  I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
 0 ;
-A S DA=$O(^DGCR(399,DA(1),"CV",DA)) I DA'>0 S DA=0 G END
+A S DA=$O(^DGCR(399,DA(1),"OT",DA)) I DA'>0 S DA=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"CV",DA,0))
+ S DIKZ(0)=$G(^DGCR(399,DA(1),"OT",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"CV","B",$E(X,1,30),DA)=""
+ I X'="" S ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA)=""
  G:'$D(DIKLM) A Q:$D(DISET)
 END G ^IBXX28
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX28.m	(revision 636)
@@ -1,13 +1,16 @@
-IBXX28 ; COMPILED XREF FOR FILE #399.048 ; 07/22/08
+IBXX28 ; COMPILED XREF FOR FILE #399.30416 ; 12/27/07
  ; 
- S DA=0
+ S DA(2)=DA(1) S DA(1)=0 S DA=0
 A1 ;
- I $D(DISET) K DIKLM S:DIKM1=1 DIKLM=1 G @DIKM1
-0 ;
-A S DA=$O(^DGCR(399,DA(1),"OT",DA)) I DA'>0 S DA=0 G END
+ I $D(DISET) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
+A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
 1 ;
- S DIKZ(0)=$G(^DGCR(399,DA(1),"OT",DA,0))
+B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
+2 ;
+ S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
  S X=$P(DIKZ(0),U,1)
- I X'="" S ^DGCR(399,DA(1),"OT","B",$E(X,1,30),DA)=""
- G:'$D(DIKLM) A Q:$D(DISET)
-END G ^IBXX29
+ I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)=""
+ S X=$P(DIKZ(0),U,2)
+ I X'="" S ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)=""
+ G:'$D(DIKLM) B Q:$D(DISET)
+END Q
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX3.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 07/22/08
+IBXX3 ; COMPILED XREF FOR FILE #399.0222 ; 12/27/07
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX4.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 07/22/08
+IBXX4 ; COMPILED XREF FOR FILE #399.0304 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX5.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 07/22/08
+IBXX5 ; COMPILED XREF FOR FILE #399.041 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX6.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 07/22/08
+IBXX6 ; COMPILED XREF FOR FILE #399.042 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX7.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 07/22/08
+IBXX7 ; COMPILED XREF FOR FILE #399.043 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX8.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 07/22/08
+IBXX8 ; COMPILED XREF FOR FILE #399.044 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX9.m	(revision 636)
@@ -1,3 +1,3 @@
-IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 07/22/08
+IBXX9 ; COMPILED XREF FOR FILE #399.045 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m
===================================================================
--- FOIAVistA/trunk/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m	(revision 631)
+++ FOIAVistA/tag/r/INTEGRATED_PATIENT_FUNDS-PRPF-PFXIP/PRPFED2.m	(revision 636)
@@ -1,4 +1,4 @@
 PRPFED2 ;ALTOONA/CTB  MISCELLANEOUS EDIT OPTIONS ;11/22/96  4:38 PM
-V ;;3.0;PATIENT FUNDS;**6,18**;JUNE 1, 1989;Build 9
+V ;;3.0;PATIENT FUNDS;**6**;JUNE 1, 1989
 LONGREG S DIC(0)="AEQLM",DIC=470,DLAYGO=470 D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE=DIC,DR="[PRPF LONG REGISTRATION]" D ^DIE G LONGREG
  ;
@@ -9,5 +9,5 @@
 ADDRESS S DIC=470,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".111;.112;.113;.114;.115;.116;.131;.132" D ^DIE G ADDRESS
  ;
-GUARDIAN S DIC=2,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".291;.2912;.2914;.2915;.2916;.2917;.2918;.2919;.292;.2922;.2923;.2924;.2925;.2926;.2927;.2928;.2929" D ^DIE G GUARDIAN
+GUARDIAN S DIC=470,DIC(0)="AEMN" D ^DIC G:Y<0 OUT^PRPFED S DA=+Y,DIE="^DPT(",DR=".291;.2912;.2914;.2915;.2916;.2917;.2918;.2919;.292;.2922;.2923;.2924;.2925;.2926;.2927;.2928;.2929" D ^DIE G GUARDIAN
  ;
 INACT ;EDIT ACCOUNT STATUS
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XGKB.m	(revision 636)
@@ -1,4 +1,4 @@
-XGKB ;SFISC/VYD - Read with Escape Processing ;10/23/2006
- ;;8.0;KERNEL;**34,244,365**;Jul 10, 1995;Build 5
+XGKB ;SFISC/VYD - Read with Escape Processing ;07/10/2002  10:58
+ ;;8.0;KERNEL;**34,244**;Jul 10, 1995
  ;;Special thanks to MELDRUM.KEVIN@ISC-SLC.VA.GOV
  ;
@@ -8,5 +8,5 @@
  I %OS["MSM" U $I:(0::::64) D:'$D(^XUTL("XGKB")) MSM^XGKB1
  I %OS["DTM" U $I:(VT=1:ESCAPE=1) D:'$D(^XUTL("XGKB")) DTM^XGKB1
- I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1 S:$G(XGTRM)="*" XGTRM=""
+ I %OS["OpenM" U $I:(:"CT") D:'$D(^XUTL("XGKB")) DTM^XGKB1
  I %OS["GT.M" U $I:(ESCAPE) D:'$D(^XUTL("XGKB")) GTM^XGKB1
  I $G(XGTRM)="*" X ^%ZOSF("TRMON") I 1 ;turn all on
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDDP.m	(revision 636)
@@ -1,227 +1,147 @@
-XPDDP ;SFISC/RSD - Display a package ;03/18/2008
- ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463,488**;Jul 10, 1995;Build 6
- ; Per VHA Directive 2004-038, this routine should not be modified.
- ; Options: XPD PRINT BUILD calls EN1
- ;          XPD PRINT INSTALL calls EN2
-EN1 ; Print from Build file
- N DIC,D0,XPD,XPDT,XPDST,Y
+XPDDP ;SFISC/RSD - Display a package ;6/21/07  09:44
+ ;;8.0;KERNEL;**21,28,44,68,100,108,229,304,346,463**;Jul 10, 1995;Build 4
+EN1 ;print from Build file
+ N DIC,D0,XPD,XPDT,XPDST,Y,Z
  S XPDST=$$LOOK^XPDB1 Q:XPDST<0
- S XPD("XPDT(")=""
- D EN^XUTMDEVQ("LST1^XPDDP","Build File Print",.XPD)
+ S XPD("XPDT(")="",Y="LST1^XPDDP",Z="Build File Print"
+ D EN^XUTMDEVQ(Y,Z,.XPD)
  Q
-EN2 ; Print from Distribution
+EN2 ;print from Distribution
  N D0,DIC,POP,XPD,XPDA,XPDNM,XPDT,XPDST,Y,Z,%ZIS
  S XPDST=$$LOOK^XPDI1("I $D(^XTMP(""XPDI"",Y))",1)
- S D0=$O(^XTMP("XPDI",XPDST,"BLD",0)) Q:'D0
- S XPD("XPDT(")=""
- D EN^XUTMDEVQ("LST2^XPDDP","Transport Global Print",.XPD)
+ S XPD("XPDT(")="",Y="LST2^XPDDP",Z="Transport Global Print",D0=$O(^XTMP("XPDI",XPDST,"BLD",0))
+ Q:'D0
+ D EN^XUTMDEVQ(Y,Z,.XPD)
  Q
-LST1 ; Print from Build file
- K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0
- F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D  Q:$D(DIRUT)
- . I XPDCNT Q:'$$CONT
- . S XPDCNT=XPDCNT+1
+ ;
+LST1 ;
+ K DIRUT N XPDIT S XPDIT=0
+ F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D
  . S D0=+XPDT(XPDIT) D PNT("XPD(9.6,D0)")
- D WAIT
  Q
-LST2 ; Print from XPDT array
- K DIRUT N XPDIT,XPDCNT S (XPDIT,XPDCNT)=0
- F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D  Q:$D(DIRUT)
- . I XPDCNT Q:'$$CONT
- . S XPDCNT=XPDCNT+1
+ ;
+LST2 ;Print from XPDT array
+ K DIRUT N XPDIT S XPDIT=0
+ F  S XPDIT=$O(XPDT(XPDIT)) Q:$D(DIRUT)!(XPDIT'>0)  D
  . S XPDA=+XPDT(XPDIT),D0=$O(^XTMP("XPDI",XPDA,"BLD",0)) D PNT("XTMP(""XPDI"",XPDA,""BLD"",D0)")
- D WAIT
  Q
-WAIT ; Pause on last page or not? It depends on whether there's enough room
- ; left on the page to display the KIDS menu.
- Q:$E($G(IOST),1,2)'="C-"
- Q:$D(DIRUT)
- ; DUZ("AUTO")=1 means show menu option choices
- I IOSL-$Y<$S($G(DUZ("AUTO")):14,1:3) D WAIT^XMXUTIL
- Q
-PNT(XPDGR) ; Print a package, XPDGR=global root
- ;XPDFL=0 - Build   - ^XPD(9.7 global root
- ;      1 - Install - ^XTMP global root
- ;      2 - Packman - ^TMP($J, global root
- N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT
+ ;
+PNT(XPDGR) ;print a package, XPDGR=global root
+ ;XPDFL=0 - Build - ^XPD(9.7 global root, 1 - Install - ^XTMP global root
+ ;2 - Packman ^TMP($J, global root
+ N I,J,K,X,XPD,XPDDT,XPDI,XPD0,XPDFL,XPDPG,XPDUL,XPDTYPE,XPDTRACK,XPDTXT,XPDOUT
  Q:$G(XPDGR)=""  S XPDGR="^"_XPDGR
  Q:'$D(@XPDGR@(0))
- D ID                     ; Package Identification
- D DESCR Q:$D(DIRUT)      ; Description
- I XPDTYPE=1 D MULT Q     ; Multi-Package
- D PREPOST Q:$D(DIRUT)    ; Environment check & Pre/Post Routines
- I XPDTYPE=2 D GLOBAL Q   ; Global Package
- D FILES Q:$D(DIRUT)      ; Files/DDs
- D COMP Q:$D(DIRUT)       ; Build Components
- Q:XPDFL=2  ; Packman message, called from XMP2 - Summarize
- D QUESTS Q:$D(DIRUT)     ; Install Questions
- D ALFABETA Q:$D(DIRUT)   ; Alpha/Beta Testing
- D NAMESP Q:$D(DIRUT)     ; Include/Exclude Namespaces
- D REQDBLD Q:$D(DIRUT)    ; Required Builds
+ S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5)
+ W:$E(IOST,1,2)="C-" @IOF D HDR W XPDUL,!
+ W "TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
+ W !,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
+ W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U)
+ W !,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO") ; new line added.
+ W !,"DESCRIPTION:"
+ S (XPDI,XPDOUT)=0
+ F  S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI  S XPDTXT=$G(^(XPDI,0)) D  Q:XPDOUT
+ . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F  S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" "
+ . F  D  Q:$L(XPDTXT)<IOM!XPDOUT!(IOM<2)  S XPDTXT=$E(XPDTXT,IOM,999)
+ . . W $S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT),!
+ . . S XPDOUT=$$CHK(2)
+ Q:$D(DIRUT)  G:XPDTYPE=1 MULT
+ W !,"ENVIRONMENT CHECK : ",$G(@XPDGR@("PRE"))
+ W ?47,"DELETE ENV ROUTINE: ",$S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No")
+ W !
+ I 'XPDTYPE D
+ . W " PRE-INIT ROUTINE : ",$G(@XPDGR@("INI"))
+ . W ?42,"DELETE PRE-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
+ . W !
+ Q:$$CHK(4)  W "POST-INIT ROUTINE : ",$G(@XPDGR@("INIT"))
+ W ?41,"DELETE POST-INIT ROUTINE: ",$S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
+ W !
+ W:'XPDTYPE "PRE-TRANSPORT RTN : ",$G(@XPDGR@("PRET")),!
+ G:XPDTYPE=2 GLOBAL
+ I '$O(@XPDGR@(4,0)) Q:$$CHK(4)  G COMP
+ S I=$$CHK(10,1) Q:I  I '$P(I,"^",2) W !! D HDR1 W XPDUL,!
+PNT2 S XPDI=0 F  S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,222)) Q:$$CHK(4,1)  D
+ .;file number, file name, partial DD
+ .W !,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI)))
+ .W ?41,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?47,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?53,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7))
+ .W ?60,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?67,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?73,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9)),!
+ .;print partial DD information
+ .I $P(XPD,U,3)="p" S J=0 D
+ ..W "Partial DD:"
+ ..F  S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J  W ?12,"subDD: ",J D  Q:$$CHK(4,1)
+ ...I '$O(@XPDGR@(4,"APDD",XPDI,J,0)) W ! Q
+ ...S I=0 F  S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I  W ?30,"fld: ",I,!
+ .I $D(@XPDGR@(4,XPDI,223)) W ?2,"DD SCREEN  : ",^(223),!
+ .I $D(@XPDGR@(4,XPDI,224)) W ?2,"DATA SCREEN: ",^(224),!
+COMP Q:$D(DIRUT)  W ! Q:$$CHK(3)  S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
+ ;print build components
+ F  S I=$O(@XPDGR@("KRN",I)),K=0,J="" Q:$D(DIRUT)!'I  F  S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J=""  S X=$O(^(J,0)) Q:$$CHK(4)  D:X
+ .S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
+ .;K is flag to write type of component
+ .I 'K W !,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",! S K=1
+ .;write the entry name and write the action
+ .W ?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2),!
+ Q:XPDFL=2
+ ;XPDFL=2 this is a Packman message, called from XMP2 - Summarize
+ ;XPDFL=1 this is a Install, the call backs are already Build Components
+ Q:$D(DIRUT)  Q:$$CHK(3)
+ I $O(@XPDGR@("QUES",0))!($D(@XPDGR@("QDEF"))#2) W !,"INSTALL QUESTIONS: " S I=0 D
+ .F  S I=$O(@XPDGR@("QUES",I)) Q:'I  S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) Q:$$CHK(5)  D
+ ..W !?5,"SUBSCRIPT: ",X,!,"DIR(0)=",J W:K]"" !,"DIR(""A"")=",K,!
+ ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"A1",J,0))  W "DIR(""A"",",J,")=",^(0),!
+ ..I $G(@XPDGR@("QUES",I,"B"))]"" W "DIR(""B"")=",^("B"),!
+ ..I $G(@XPDGR@("QUES",I,"Q"))]"" W "DIR(""?"")=",^("Q"),!
+ ..F J=1:1 Q:'$D(@XPDGR@("QUES",I,"Q1",J,0))  W "DIR(""?"",",J,")=",^(0),!
+ ..I $G(@XPDGR@("QUES",I,"QQ"))]"" W "DIR(""??"")=",^("QQ"),!
+ ..I $G(@XPDGR@("QUES",I,"M"))]"" W "M CODE: ",^("M"),!
+ . Q:$D(DIRUT)  Q:$$CHK(3)
+ . ;Show new Defaults for KIDS questions. p463
+ . I $D(@XPDGR@("QDEF"))#2 S X=$G(@XPDGR@("QDEF")) D
+ . . W:$X>1 !
+ . . I $L($P(X,U,9)) W " Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9),!
+ . . I $L($P(X,U,5)) W " Default INHIBIT LOGONs during the install: ",$P(X,U,5),!
+ . . I $L($P(X,U,11)) W " Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11)
+ . . Q
+ . Q
+ Q:$D(DIRUT)  Q:$$CHK(3)
+ I $L($G(@XPDGR@("ABPKG"))) S XPD=^("ABPKG") D:$P(XPD,U)="y"
+ .W !,"ALPHA/BETA TESTING:",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?40,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
+ .W !,"ADDRESS: ",$P(XPD,U,3),!!,"INCLUDE NAMESPACE",?30,"EXCLUDE NAMESPACE" S I=0
+ .F  S I=$O(@XPDGR@("ABNS",I)),J=0 Q:'I  W !?5,^(I,0) F  S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J  W ?35,^(J,0),! Q:$$CHK(3)
+REQB Q:$D(DIRUT)  Q:$$CHK(4)
+ I $O(@XPDGR@("REQB",0)) W !,"REQUIRED BUILDS:",?50,"ACTION:" D
+ .S XPDI=0 F  S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
+ ..W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
  Q
-ID ; Identify the package
- S XPD0=^(0),XPDPG=1,XPDFL=$S($E(XPDGR,1,5)="^TMP(":2,1:$E(XPDGR,1,5)="^XTMP"),$P(XPDUL,"-",IOM)="",XPDDT=$$HTE^XLFDT($H,"1PM"),XPDTYPE=+$P(XPD0,U,3),XPDTRACK=$P(XPD0,U,5)
- W:$E(IOST,1,2)="C-" @IOF D HDR W !,XPDUL
- W !,"TYPE: ",$$EXTERNAL^DILFD(9.6,2,"",XPDTYPE)
- W ?51,"TRACK NATIONALLY: ",$$EXTERNAL^DILFD(9.6,5,"",XPDTRACK)
- W !,"NATIONAL PACKAGE: ",$P($G(^DIC(9.4,+$P(XPD0,U,2),0),$P(XPD0,U,2)),U)
- W ?49,"ALPHA/BETA TESTING: ",$S($P($G(@XPDGR@("ABPKG")),U)="y":"YES",1:"NO")
- Q
-DESCR ; Show patch description
- W !!,"DESCRIPTION:"
- S XPDI=0
- F  S XPDI=$O(@XPDGR@(1,XPDI)) Q:'XPDI  S XPDTXT=$G(^(XPDI,0)) D  Q:$D(DIRUT)
- . I $L(XPDTXT)'<IOM,$E(XPDTXT,$L(XPDTXT))=" " F  S XPDTXT=$E(XPDTXT,1,$L(XPDTXT)-1) Q:$E(XPDTXT,$L(XPDTXT))'=" "
- . F  D  Q:$L(XPDTXT)<IOM!$D(DIRUT)!(IOM<2)  S XPDTXT=$E(XPDTXT,IOM,999)
- . . Q:$$CHK(2)
- . . W !,$S(IOM>1:$E(XPDTXT,1,IOM-1),1:XPDTXT)
- Q
-PREPOST ; Environment check and pre/post routines
- Q:$$CHK(3)
- W !!,"ENVIRONMENT CHECK: ",$G(@XPDGR@("PRE"))
- W ?49,"DELETE ENV ROUTINE: " I $G(@XPDGR@("PRE"))]"" W $S($P($G(@XPDGR@("INID")),U)="y":"Yes",1:"No")
- I 'XPDTYPE D  Q:$D(DIRUT)
- . Q:$$CHK(2)
- . W !," PRE-INIT ROUTINE: ",$G(@XPDGR@("INI"))
- . W ?44,"DELETE PRE-INIT ROUTINE: " I $G(@XPDGR@("INI"))]"" W $S($P($G(@XPDGR@("INID")),U,3)="y":"Yes",1:"No")
- Q:$$CHK(2)
- W !,"POST-INIT ROUTINE: ",$G(@XPDGR@("INIT"))
- W ?43,"DELETE POST-INIT ROUTINE: " I $G(@XPDGR@("INIT"))]"" W $S($P($G(@XPDGR@("INID")),U,2)="y":"Yes",1:"No")
- I 'XPDTYPE Q:$$CHK(2)  W !,"PRE-TRANSPORT RTN: ",$G(@XPDGR@("PRET"))
- Q
-FILES ; Show files/DDs
- Q:'$O(@XPDGR@(4,0))  ; Quit if no files
- S I=$$CHK(8,1) Q:I  I '$P(I,"^",2) D HDR1 W !,XPDUL
- S XPDI=0
- F  S XPDI=$O(@XPDGR@(4,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,222)) Q:$$CHK(3,1)  D
- . ;file number, file name, partial DD
- . W !!,XPDI,?12,$S('XPDFL:$P($G(^DIC(XPDI,0),"**unknown**"),U),1:$G(^XTMP("XPDI",XPDA,"FIA",XPDI)))
- . ; update DD, send security code, data comes with file
- . W ?43,$$EXTERNAL^DILFD(9.64,222.1,"",$P(XPD,U)),?49,$$EXTERNAL^DILFD(9.64,222.2,"",$P(XPD,U,2)),?55,$$EXTERNAL^DILFD(9.64,222.7,"",$P(XPD,U,7))
- . ; override site data, resolve pointers, user override
- . W ?63,$E($$EXTERNAL^DILFD(9.64,222.8,"",$P(XPD,U,8)),1,4),?69,$$EXTERNAL^DILFD(9.64,222.5,"",$P(XPD,U,5)),?75,$$EXTERNAL^DILFD(9.64,222.9,"",$P(XPD,U,9))
- . I $P(XPD,U,3)="p" D  Q:$D(DIRUT)
- . . ; Print partial DD information
- . . N XPDSUB,XPDFLD
- . . Q:$$CHK(2,1)
- . . W !,"Partial DD:"
- . . S (J,XPDSUB)=0
- . . F  S J=$O(@XPDGR@(4,"APDD",XPDI,J)) Q:'J  D  Q:$D(DIRUT)
- . . . I XPDSUB Q:$$CHK(2,1)  W !
- . . . W ?12,"subDD: ",J
- . . . S XPDSUB=1,(I,XPDFLD)=0
- . . . F  S I=$O(@XPDGR@(4,"APDD",XPDI,J,I)) Q:'I  D  Q:$D(DIRUT)
- . . . . I XPDFLD Q:$$CHK(2,1)  W !
- . . . . W ?30,"fld: ",I S XPDFLD=1
- . I "  "'[$G(@XPDGR@(4,XPDI,223)) Q:$$CHK(2,1)  W !,?2,"DD SCREEN  : ",^(223)
- . I "  "'[$G(@XPDGR@(4,XPDI,224)) Q:$$CHK(2,1)  W !,?2,"DATA SCREEN: ",^(224)
- Q
-COMP ; Print Build components
- S I=0,XPD=$P(^DD(9.68,.03,0),U,3)
- F  S I=$O(@XPDGR@("KRN",I)) Q:'I  D   Q:$D(DIRUT)
- . Q:'$D(@XPDGR@("KRN",I,"NM","B"))
- . Q:$$CHK(4)
- . W !!,$S($D(^DIC(I,0)):$P(^(0),U),XPDFL:$G(^XTMP("XPDI",XPDA,"FIA",I),"UNKNOWN"),1:"UNKNOWN")_":",?47,"ACTION:"
- . S J=""
- . F  S J=$O(@XPDGR@("KRN",I,"NM","B",J)) Q:J=""  S X=$O(^(J,0)) D  Q:$D(DIRUT)
- . . Q:'X
- . . S X=$G(@XPDGR@("KRN",I,"NM",X,0)) Q:X=""
- . . Q:$$CHK(2)
- . . ;write the entry name and write the action
- . . W !,?3,$P(X,U),?50,$P($P(XPD,";",$P(X,U,3)+1),":",2)
- Q
-QUESTS ; Show Install Questions
- I '$O(@XPDGR@("QUES",0)),'($D(@XPDGR@("QDEF"))#2) Q
- Q:$$CHK(6)
- W !!,"INSTALL QUESTIONS: "
- S I=0
- F  S I=$O(@XPDGR@("QUES",I)) Q:'I  S X=$P(^(I,0),U),J=$G(^(1)),K=$G(^("A")) D  Q:$D(DIRUT)
- . Q:$$CHK(4)
- . W !!?5,"SUBSCRIPT: ",X
- . W !,"DIR(0)=",J
- . S J=0
- . F  S J=$O(@XPDGR@("QUES",I,"A1",J)) Q:'J  Q:$$CHK(2)  W !,"DIR(""A"",",J,")=",^(J,0)
- . I K]"" Q:$$CHK(2)  W !,"DIR(""A"")=",K
- . I $G(@XPDGR@("QUES",I,"B"))]"" Q:$$CHK(2)  W !,"DIR(""B"")=",^("B")
- . S J=0
- . F  S J=$O(@XPDGR@("QUES",I,"Q1",J)) Q:'J  Q:$$CHK(2)  W !,"DIR(""?"",",J,")=",^(J,0)
- . I $G(@XPDGR@("QUES",I,"Q"))]"" Q:$$CHK(2)  W !,"DIR(""?"")=",^("Q")
- . I $G(@XPDGR@("QUES",I,"QQ"))]"" Q:$$CHK(2)  W !,"DIR(""??"")=",^("QQ")
- . I $G(@XPDGR@("QUES",I,"M"))]"" Q:$$CHK(2)  W !,"M CODE: ",^("M")
- Q:$D(DIRUT)
- ;Show new Defaults for KIDS questions. p463
- S X=$G(@XPDGR@("QDEF")) Q:X=""
- I '$L($P(X,U,9)),'$L($P(X,U,5)),'$L($P(X,U,11)) Q
- Q:$$CHK(3)  W !
- I $L($P(X,U,9)) Q:$$CHK(2)  W !," Default Rebuild Menu Trees Upon Completion of Install: ",$P(X,U,9)
- I $L($P(X,U,5)) Q:$$CHK(2)  W !," Default INHIBIT LOGONs during the install: ",$P(X,U,5)
- I $L($P(X,U,11)) Q:$$CHK(2)  W !," Default DISABLE Scheduled Options, Menu Options, and Protocols: ",$P(X,U,11)
- Q
-ALFABETA ; Alpha/Beta Testing
- S XPD=$G(@XPDGR@("ABPKG")) Q:XPD=""
- Q:$P(XPD,U)'="y"
- Q:$$CHK(4)
- W !!,"ALPHA/BETA TESTING: ",$$EXTERNAL^DILFD(9.6,20,"",$P(XPD,U)),?47,"INSTALLATION MESSAGE: ",$$EXTERNAL^DILFD(9.6,21,"",$P(XPD,U,2))
- W !,"ADDRESS: ",$P(XPD,U,3)
- Q
-NAMESP ; Namespaces
- Q:'$O(@XPDGR@("ABNS",0))
- Q:$$CHK(4)
- W !!,"INCLUDE NAMESPACE:",?47,"EXCLUDE NAMESPACE:"
- S I=0
- F  S I=$O(@XPDGR@("ABNS",I)) Q:'I  Q:$$CHK(2)  W !?3,^(I,0) D  Q:$D(DIRUT)
- . N XPDNMSP,XPDLF
- . S (J,XPDLF)=0
- . F  S J=$O(@XPDGR@("ABNS",I,1,J)) Q:'J  S XPDNMSP=^(J,0) D  Q:$D(DIRUT)
- . . I XPDLF Q:$$CHK(2)  W !
- . . W ?50,XPDNMSP
- . . S XPDLF=1
- Q
-REQDBLD ; Required Builds
- Q:'$O(@XPDGR@("REQB",0))
- Q:$$CHK(4)
- W !!,"REQUIRED BUILDS:",?47,"ACTION:"
- S XPDI=0
- F  S XPDI=$O(@XPDGR@("REQB",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(2)  D
- . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.611,1,"",$P(XPD,U,2))
- Q
-GLOBAL ; Global Package
- Q:$$CHK(4)
- W !!,"GLOBAL:",?47,"KILL GLOBAL BEFORE INSTALL:"
- S XPDI=0
- F  S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(2)  D
- . W !?3,$P(XPD,U),?50,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
- Q
-MULT ; Multi-Package
- Q:$$CHK(4)
- W !!,"SEQUENCE OF BUILDS:"
- S XPDI=0
- F  S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(2)  D
- . W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
- Q
+GLOBAL ;globals listing
+ S I=$$CHK(8,1) Q:I  I '$P(I,"^",2) W !!,"GLOBAL:",?20,"KILL GLOBAL BEFORE INSTALL:"
+ S XPDI=0 F  S XPDI=$O(@XPDGR@("GLO",XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
+ .W !?3,$P(XPD,U),?33,$$EXTERNAL^DILFD(9.65,1,"",$P(XPD,U,2))
+ W ! Q
+ ;
+MULT ;multiple-package
+ S I=$$CHK(10,1) Q:I  I '$P(I,"^",2) W !,"SEQUENCE OF BUILDS:"
+ S XPDI=0 F  S XPDI=$O(@XPDGR@(10,XPDI)) Q:'XPDI  S XPD=$G(^(XPDI,0)) Q:$$CHK(4,1)  D
+ .W !?2,XPDI,?8,$E($P(XPD,U),1,44),?54,$S($P(XPD,U,2)=1:"",1:"Not ")_"Required to Continue"
+ W ! Q
+ ;
+ ;return 0 if header was not written, else "0^1"
 CHK(Y,XPD) ;Y=excess lines XPD=1 print file header, return 1 to exit
- ;return 0 if header was not written, else "0^1"
  Q:$Y<(IOSL-Y) 0
- Q:'$$CONT 1
+ I $E(IOST,1,2)="C-" D  Q:'Y 1
+ .N DIR,I,J,K,X
+ .S DIR(0)="E" D ^DIR
  S XPD=$G(XPD),XPDPG=XPDPG+1
  W @IOF D HDR,HDR1:XPD
- W !,XPDUL
+ W XPDUL,!
  Q "0^1"
-CONT() ; Press Return to continue; ^ to exit.
- Q:$D(DIRUT) 0
- Q:$E(IOST,1,2)'="C-" 1
- N DIR,I,J,K,X,Y
- S DIR(0)="E" D ^DIR
- Q Y
+ ;
 XMP2(X,D0) ;called from ^XMP2
  N XPDA S XPDA=-1
- D PNT(X)
+ D PNT(X) Q
+ ;
+HDR W !,"PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,"PAGE ",XPDPG,!
  Q
-HDR ;
- W "PACKAGE: ",$P(XPD0,U),"     ",XPDDT,?70,$$RJ^XLFSTR("PAGE "_XPDPG,9)
+HDR1 W ?41,"UP",?47,"SEND",?53,"DATA",?73,"USER",!,?41,"DATE",?47,"SEC.",?53,"COMES",?60,"SITE",?67,"RSLV",?73,"OVER"
+ W !,"FILE #",?12,"NAME",?41,"DD",?47,"CODE",?53,"W/FILE",?60,"DATA",?67,"PTS",?73,"RIDE",!
  Q
-HDR1 ;
- W !!,?43,"UP    SEND  DATA                USER"
- W !,?43,"DATE  SEC.  COMES   SITE  RSLV  OVER"
- W !,"FILE #",?12,"FILE NAME",?43,"DD    CODE  W/FILE  DATA  PTRS  RIDE"
- Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI.m	(revision 636)
@@ -1,3 +1,3 @@
-XPDI ;SFISC/RSD - Install Process ;9/16/02  13:29
+XPDI ;SFISC/RSD - Install Process ;9:53 AM  31 Jan 2008
  ;;8.0;KERNEL;**10,21,39,41,44,58,68,108,145,184,229**;Jul 10, 1995
 EN ;install
@@ -6,4 +6,10 @@
  Q:'XPDST!$D(XPDQUIT)
  S XPDIT=0,(XPDSET,XPDSET1)=$P(^XPD(9.7,XPDST,0),U) K ^TMP($J)
+ ;;
+ ;; Patch checker , points to file # 9.6  ; RED
+ D EN^VEPEFKPC(.XPDT,.XPDQUIT,1053) Q:$D(XPDQUIT)    ;VOE 1 Patch
+ D EN^VEPEFKPC(.XPDT,.XPDQUIT,1054) Q:$D(XPDQUIT)    ;VOE 1.1 Patch
+ D EN^VEPEFKPC(.XPDT,.XPDQUIT,7397) Q:$D(XPDQUIT)    ;NO HOME 1.0 Patch
+ ;
  ;Check each part of XPDT array
  F  S XPDIT=$O(XPDT(XPDIT)) Q:'XPDIT  D  Q:'$D(XPDT)!$D(XPDQUIT)
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDI1.m	(revision 636)
@@ -1,8 +1,9 @@
-XPDI1 ;SFISC/RSD - Cont of Install Process ;10/28/2002  17:14
- ;;8.0;KERNEL;**58,61,95,108,229,275**;Jul 10, 1995
+XPDI1 ;SFISC/RSD - Cont of Install Process ; 8/30/04 9:45am
+ ;;8.0;KERNEL;**58,61,95,108,229,275,L33**;Jul 10, 1995
  ;lookup into file 9.7, XPDS=DIC("S") for lookup
  ;return 0-fail or ien, XPDT=array of linked builds
 LOOK(XPDS,XPDL) ;lookup Install
  N DIC,Y,XPD,XPDIT,%
+ S:$D(AAQP) DIC("B")=AAQP ;MPLS XU*L33 used only by XPDZPAT and AAQMENU
  S DIC(0)="QEAMZ",DIC="^XPD(9.7,"
  S:$L($G(XPDS)) DIC("S")=XPDS
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIL.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIL.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIL.m	(revision 636)
@@ -1,3 +1,3 @@
-XPDIL ;SFISC/RSD - load Distribution Global ;05/17/2006
+XPDIL ;SFISC/RSD - load Distribution Global ;10/10/06  17:00
  ;;8.0;KERNEL;**15,44,58,68,108,422**;Jul 10, 1995;Build 2
  ;This routine has the changes made for patch 345 but was released as 422 to fix a read HFS problem
@@ -41,4 +41,6 @@
  I '$G(XPDAUTO) D HOME^%ZIS
  I $G(XPDAUTO) S IO(0)=XPDDEV
+ S:$D(AAQFILE) DIR("B")=AAQFILE ;L33 used only by XPDZPAT
+ S:$D(AAQFILE) DIR("B")=AAQFILE ;L33 used only by XPDZPAT - line added for VOE
  S DIR(0)="F^3:75",DIR("A")="Enter a Host File",DIR("?")="Enter a filename and/or path to input Distribution."
  ;p345-rename AND* to XPD*
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XPDIST.m	(revision 636)
@@ -1,9 +1,8 @@
-XPDIST ;SFISC/RSD - site tracking; 06/01/2006 ;03/05/2008
- ;;8.0;KERNEL;**66,108,185,233,350,393,486**;Jul 10, 1995;Build 5
- ; Per VHA Directive 2004-038, this routine should not be modified.
+XPDIST ;SFISC/RSD - site tracking; 06/01/2006
+ ;;8.0;KERNEL;**66,108,185,233,350,393**;Jul 10, 1995;Build 12
  ;Returns ""=failed, XMZ=sent
  ;D0=ien in file 9.7, XPY=national site tracking^address(optional)
 EN(D0,XPY) ;send message
- N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPZ,X,X1,Z,Y,XPD6,XPDTRACK
+ N %,DIFROM,XPD,XPD0,XPD1,XPD2,XPDV,XPDTEXT,XPZ,XMDUZ,XMSUB,XMTEXT,XMY,XMZ,X,X1,Z,Y,XPD6
  ;Get data needed
  I '$D(^XPD(9.7,$G(D0),0)) D BMES^XPDUTL(" INSTALL file entry missing") Q ""
@@ -16,10 +15,38 @@
  S XPZ(1)=$P(XPD1,U),XPZ(2)=$P(XPD1,U,3),XPZ(3)=$$FMDIFF^XLFDT(XPZ(2),XPZ(1),3),XPZ(1)=$$FMTE^XLFDT(XPZ(1)),XPZ(2)=$$FMTE^XLFDT(XPZ(2))
  D LOCAL
- S XPDTRACK=$$TRACK
  D REMEDY ;p350 -REM
  Q $$FORUM()
+ ;
+ ;
+FORUM() ;send to Server on FORUM
+ K XMY,XPDTEXT ;393
+ Q:$G(XPY)="" ""
+ S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")="" ;,XMY("ESSRESOURCE@MED.VA.GOV")=""
+ S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
+ K ^TMP($J)
+ ;Quit if not VA production primary domain
+ I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q ""
+ X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
+ S:%'["," Y=$P(Y,",")
+ I Y'=% D BMES^XPDUTL(" Not a production UCI") Q ""
+ ;Message for server
+ S XPDTEXT(1,0)="PACKAGE INSTALL"
+ S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME"))
+ S XPDTEXT(3,0)="PACKAGE: "_XPD
+ S XPDTEXT(4,0)="VERSION: "_XPDV
+ S XPDTEXT(5,0)="Start time: "_XPZ(1)
+ S XPDTEXT(6,0)="Completion time: "_XPZ(2)
+ S XPDTEXT(7,0)="Run time: "_XPZ(3)
+ S XPDTEXT(8,0)="DATE: "_DT
+ S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
+ S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U)
+ S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4)
+ S XPDTEXT(12,0)=XPD2
+ S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"
+ D ^XMD
+ Q "#"_$G(XMZ)
+ ;
 LOCAL ;Send a message to local mail group
- N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
- K ^TMP($J)
+ K ^TMP($J),XMY,XPDTEXT,XMTEXT
  S X=$$MAILGRP^XPDUTL(XPD) Q:X=""
  S XMY(X)="" D GETENV^%ZOSV
@@ -38,20 +65,15 @@
  D ^XMD
  Q
-TRACK() ; Should VA track the installation of this patch at a national level?
- Q:$G(XPY)="" 0  ; No - National site tracking was not requested
- ;Quit if not VA production primary domain
- I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q 0
- ;X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
- ;S:%'["," Y=$P(Y,",")
- ;I Y'=% D BMES^XPDUTL(" Not a production UCI") Q ""
- ; 486/GMB Replaced the above 3 lines with the following line:
- I '$$PROD^XUPROD D BMES^XPDUTL(" Not a production UCI") Q 0
- Q 1
+ ;
 REMEDY ;Send to Remedy Server - ESSRESOURCE@MED.VA.GOV *p350 -REM
- Q:'XPDTRACK
- N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
- K ^TMP($J)
+ K ^TMP($J),XMY,XPDTEXT,XMTEXT ;393
+ Q:$G(XPY)=""
  S:XPY XMY("ESSRESOURCE@MED.VA.GOV")=""
  S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
+ ;Quit if not VA production primary domain
+ I $G(^XMB("NETNAME"))'[".VA.GOV" D BMES^XPDUTL(" Not a VA primary domain") Q
+ X ^%ZOSF("UCI") S %=^%ZOSF("PROD")
+ S:%'["," Y=$P(Y,",")
+ I Y'=% D BMES^XPDUTL(" Not a production UCI") Q
  ;Message for server (all in one string)
  ;XMTEXT=Type(1),Domain(2-65),Pkg(66-95),Version(96-125),
@@ -68,24 +90,2 @@
  D ^XMD
  Q
-FORUM() ;send to Server on FORUM
- Q:'XPDTRACK ""
- N XMY,XPDTEXT,XMTEXT,XMDUZ,XMSUB,XMZ
- K ^TMP($J)
- S:XPY XMY("S.A5CSTS@FORUM.VA.GOV")=""
- S:$L($P(XPY,U,2)) XMY($P(XPY,U,2))=""
- ;Message for server
- S XPDTEXT(1,0)="PACKAGE INSTALL"
- S XPDTEXT(2,0)="SITE: "_$G(^XMB("NETNAME"))
- S XPDTEXT(3,0)="PACKAGE: "_XPD
- S XPDTEXT(4,0)="VERSION: "_XPDV
- S XPDTEXT(5,0)="Start time: "_XPZ(1)
- S XPDTEXT(6,0)="Completion time: "_XPZ(2)
- S XPDTEXT(7,0)="Run time: "_XPZ(3)
- S XPDTEXT(8,0)="DATE: "_DT
- S XPDTEXT(9,0)="Installed by: "_$P($G(^VA(200,+$P(XPD0,U,11),0)),U)
- S XPDTEXT(10,0)="Install Name: "_$P(XPD0,U)
- S XPDTEXT(11,0)="Distribution Date: "_$P(XPD1,U,4)
- S XPDTEXT(12,0)=XPD2
- S XMDUZ=$S($P(XPD0,U,11):+$P(XPD0,U,11),1:.5),XMTEXT="XPDTEXT(",XMSUB=$P(XPD0,U)_" INSTALLATION"
- D ^XMD
- Q "#"_$G(XMZ)
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ3.m	(revision 636)
@@ -1,7 +1,6 @@
-XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/30/08  17:06
- ;;8.0;KERNEL;**80,501**;Jul 10, 1995;Build 1
+XQ3 ;LL/THM,SF/GJL,SEA/JLI - CLEANUP DANGLING POINTERS IN OPTION OR HELP FRAME FILES ;04/21/98  13:20
+ ;;8.0;KERNEL;**80**;Jul 10, 1995
  Q
 ENASK ;Ask to fix up dirty OPTION/HELP FRAME File
- N IX,XUT,J,K,XQFL,X
  I '$D(%) W !,$C(7),"ENTRY MUST BE WITH THE VARIABLE '%' SET TO INDICATE DESIRED FILE.",$C(7),! Q
  S XQFL=$S(%=1:"OPTION",%=2:"PROTOCOL",1:"HELP FRAME")
@@ -22,87 +21,63 @@
  W !!,"Enter:  NO or ^ to continue on without effecting the ",XQFL," File."
  W ! G ENASK
-REMOVE D:%=1 OPFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'XUT W "(no bad pointers)."
- E  W "now (",XUT," pointer" W:XUT>1 "s" W " fixed)."
- W ! S X="Y"
+REMOVE D:%=1 ENFIX D:%=2 PFIX D:'% HFFIX W !,"Your ",XQFL," File is OK " I 'X W "(no bad pointers)."
+ E  W "now (",X," pointer" W:X>1 "s" W " fixed)."
+ W ! S X="Y" Q
+ENFIX ;Kill any dangling pointers in the OPTION File (#19)
+ S (I,X)=0 ;X=Total Deletions
+L1 S I=$O(^DIC(19,I)) I I>0 S (Y,J)=0 G L2 ;Loop through menus
  Q
-OPFIX ;Kill any dangling pointers in the OPTION File (#19)
- N %,IX,J,XQ3
- S (IX,XUT)=0 ;XUT=Total Deletions
- F  S IX=$O(^DIC(19,IX)) Q:'IX  W:'(IX#100) ". " S (XQ3,J)=0 D L2 ;Loop through Options
- D NPF
+L2 S J=$O(^DIC(19,I,10,J)) I J>0 G ITEM ;Loop through menu items
+ I '$D(^DIC(19,I,10,0)) G L1
+ S (K,J)=0 F L=1:1 S J=$O(^DIC(19,I,10,J)) Q:J'>0  S K=J ;K=Last item
+ S J=^DIC(19,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
+ G XREFS
+ITEM S K=+^DIC(19,I,10,J,0) I $D(^DIC(19,K,0)) S Y=Y+1 G L2 ;Y=No. of items
+ W !,"Option ",$P(^DIC(19,I,0),U,1)," points to missing option ",K
+ S X=X+1 K ^DIC(19,I,10,J) ;Kill invalid menu item
+ G L2
+XREFS S K=":"
+L3 S K=$O(^DIC(19,I,10,K)) I K="" G L1 ;Loop through cross references
+ S L=-1
+L4 S L=$O(^DIC(19,I,10,K,L)) I L="" G L3
+ S J=0
+L5 S J=$O(^DIC(19,I,10,K,L,J)) I J'>0 G L4
+ I '$D(^DIC(19,I,10,J,0)) G KILLXR ;kill xref to invalid item
+L6 S M=^DIC(19,I,10,J,0) I (M=L)!(M[L_"^") G L5
+KILLXR K ^DIC(19,I,10,K,L,J) I $O(^DIC(19,I,10,K,L,-1))="" K ^DIC(19,I,10,K,L)
+ G L5
+HFFIX ; Fix dangling pointers on help frame file
+ S (X,I)=0 F  S I=$O(^DIC(9.2,I)) Q:I'>0  I $D(^(I,2)) D HF1,HF2,HF3
  Q
-L2 ;One Option
- I '$D(^DIC(19,IX,10,0)) Q  ;Not a Menu
- K ^DIC(19,IX,10,"B") ;Rebuild "B" X-ref
- F  S J=$O(^DIC(19,IX,10,J)) Q:'J  D ITEM ;Loop through menu items
- S (K,J)=0 F  S J=$O(^DIC(19,IX,10,J)) Q:J'>0  S K=J ;K=Last item
- S J=^DIC(19,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_XQ3 ;fix counters
+HF1 S (Y,J)=0 F  S J=$O(^DIC(9.2,I,2,J)) Q:J'>0  I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,X=X+1 K ^DIC(9.2,I,2,J,0)
  Q
- ;
-ITEM ;One Menu item
- N DA,DIK
- S K=+^DIC(19,IX,10,J,0)
- I $D(^DIC(19,K,0)) S XQ3=XQ3+1,^DIC(19,IX,10,"B",K,J)="" Q  ;Y=No. of items
- W !,"Option ",$P(^DIC(19,IX,0),U,1)," points to missing option ",K
- ;S XUT=XUT+1 K ^DIC(19,IX,10,J) ;Kill invalid menu item
- S XUT=XUT+1,DIK="^DIC(19,DA(1),10,",DA=J,DA(1)=IX D ^DIK ;Trigger Menu-rebuild
+HF2 S (K,J)=0 F  S J=$O(^DIC(9.2,I,2,J)) Q:J'>0  S K=J
+ S J=^DIC(9.2,I,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y
  Q
- ;
-NPF ;Fix the New Person File Option Pointers
- N IX,I2,J,P,DIK,DIE,DR,DA,XUT
- S (XUT,IX)=0
- F  S IX=$O(^VA(200,IX)) Q:'IX  D
- . S P=+$G(^VA(200,IX,201))
- . I P,'$D(^DIC(19,P,0)) D
- . . W !,"User: ",$P(^VA(200,IX,0),U),", Primary Menu points to missing option ",P
- . . S XUT=XUT+1,DIE="^VA(200,",DA=IX,DR="201///@" D ^DIE
- . . Q
- . S I2=0
- . F  S I2=$O(^VA(200,IX,203,I2)) Q:'I2  D
- . . S P=+$G(^VA(200,IX,203,I2,0))
- . . I P,'$D(^DIC(19,P,0)) D
- . . . W !,"User: ",$P(^VA(200,IX,0),U),", Secondary Menu points to missing option ",P
- . . . S XUT=XUT+1,DIK="^VA(200,DA(1),203,",DA=I2,DA(1)=IX D ^DIK
- . . . Q
- . . Q
- . Q
- I XUT W !,"Menu pointers fixed."
+HF3 S K=":" F  S K=$O(^DIC(9.2,I,2,K)) Q:K=""  S J=-1 F  S J=$O(^DIC(9.2,I,2,K,J)) Q:J=""  D HF4
  Q
-HFFIX ; Fix dangling pointers on help frame file
- N %
- S (XUT,IX)=0 F  S IX=$O(^DIC(9.2,IX)) Q:IX'>0  I $D(^(IX,2)) D HF1,HF2,HF3
- Q
-HF1 S (Y,J)=0 F  S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0  I $D(^(J,0)) S K=$P(^(0),U,2),Y=Y+1 I $L(K),'$D(^DIC(9.2,K)) S Y=Y-1,XUT=XUT+1 K ^DIC(9.2,IX,2,J,0)
- Q
-HF2 S (K,J)=0 F  S J=$O(^DIC(9.2,IX,2,J)) Q:J'>0  S K=J
- S J=^DIC(9.2,IX,2,0),^(0)=$P(J,U,1,2)_U_K_U_Y
- Q
-HF3 S K=":" F  S K=$O(^DIC(9.2,IX,2,K)) Q:K=""  S J=-1 F  S J=$O(^DIC(9.2,IX,2,K,J)) Q:J=""  D HF4
- Q
-HF4 S JJ=0 F  S JJ=$O(^DIC(9.2,IX,2,K,J,JJ)) Q:JJ'>0  I '$D(^DIC(9.2,IX,2,JJ,0)) K ^DIC(9.2,IX,2,K,J,JJ)
+HF4 S JJ=0 F  S JJ=$O(^DIC(9.2,I,2,K,J,JJ)) Q:JJ'>0  I '$D(^DIC(9.2,I,2,JJ,0)) K ^DIC(9.2,I,2,K,J,JJ)
  Q
 PFIX ;Kill any dangling pointers in the PROTOCOL File (#101)
- N %
- S (IX,XUT)=0 ;XUT=Total Deletions
-P1 S IX=$O(^ORD(101,IX)) I IX>0 S (Y,J)=0 G P2 ;Loop through protocols
+ S (I,X)=0 ;X=Total Deletions
+P1 S I=$O(^ORD(101,I)) I I>0 S (Y,J)=0 G P2 ;Loop through protocols
  Q
-P2 S J=$O(^ORD(101,IX,10,J)) I J>0 G PITEM ;Loop through items
- I '$D(^ORD(101,IX,10,0)) G P1
- S (K,J)=0 F L=1:1 S J=$O(^ORD(101,IX,10,J)) Q:J'>0  S K=J ;K=Last item
- S J=^ORD(101,IX,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
+P2 S J=$O(^ORD(101,I,10,J)) I J>0 G PITEM ;Loop through items
+ I '$D(^ORD(101,I,10,0)) G P1
+ S (K,J)=0 F L=1:1 S J=$O(^ORD(101,I,10,J)) Q:J'>0  S K=J ;K=Last item
+ S J=^ORD(101,I,10,0),^(0)=$P(J,"^",1,2)_"^"_K_"^"_Y ;fix counters
  G PXREFS
-PITEM S K=+^ORD(101,IX,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items
- W !,"Protocol ",$P(^ORD(101,IX,0),U,1)," points to missing protocol ",K
- ;S XUT=XUT+1 K ^ORD(101,IX,10,J) ;Kill invalid menu item
- S XUT=XUT+1,DIK="^ORD(101,IX,10,",DA=J,DA(1)=IX D ^DIK ;Delete invalid menu item
+PITEM S K=+^ORD(101,I,10,J,0) I $D(^ORD(101,K,0)) S Y=Y+1 G P2 ;Y=No. of items
+ W !,"Option ",$P(^ORD(101,I,0),U,1)," points to missing option ",K
+ S X=X+1 K ^ORD(101,I,10,J) ;Kill invalid menu item
  G P2
 PXREFS S K=":"
-P3 S K=$O(^ORD(101,IX,10,K)) I K="" G P1 ;Loop through cross references
+P3 S K=$O(^ORD(101,I,10,K)) I K="" G P1 ;Loop through cross references
  S L=-1
-P4 S L=$O(^ORD(101,IX,10,K,L)) I L="" G P3
+P4 S L=$O(^ORD(101,I,10,K,L)) I L="" G P3
  S J=0
-P5 S J=$O(^ORD(101,IX,10,K,L,J)) I J'>0 G P4
- I '$D(^ORD(101,IX,10,J,0)) G PKILLXR ;kill xref to invalid item
-P6 S M=^ORD(101,IX,10,J,0) I (M=L)!(M[L_"^") G P5
-PKILLXR K ^ORD(101,IX,10,K,L,J) I $O(^ORD(101,IX,10,K,L,-1))="" K ^ORD(101,IX,10,K,L)
+P5 S J=$O(^ORD(101,I,10,K,L,J)) I J'>0 G P4
+ I '$D(^ORD(101,I,10,J,0)) G PKILLXR ;kill xref to invalid item
+P6 S M=^ORD(101,I,10,J,0) I (M=L)!(M[L_"^") G P5
+PKILLXR K ^ORD(101,I,10,K,L,J) I $O(^ORD(101,I,10,K,L,-1))="" K ^ORD(101,I,10,K,L)
  G P5
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ5.m	(revision 636)
@@ -1,6 +1,4 @@
-XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;01/30/2008
- ;;8.0;KERNEL;**44,130,484**;Jul 10, 1995;Build 2
- ; Per VHA Directive 2004-038, this routine should not be modified.
- ; Option & Input Template: XUEDITOPT
+XQ5 ;SF/GFT,MJM,KLD - Menu edit utilities [XUEDITOPT] ;09/20/96  15:33
+ ;;8.0;KERNEL;**44,130**;Jul 10, 1995
 DIP ;
  K DIC S DIC=.4,DIC(0)="AEQMZ" I $D(^DIC(19,DA,63)),^(63)?1"[".E1"]" S DIC("B")=$E(^(63),2,$L(^(63))-1)
@@ -33,11 +31,8 @@
 Q1 K XQDIC,XQ,Y S DIC=DIE Q
  ;
-DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2)
- S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
+DIC S XQ=$P(^DIC(XQDIC,0),U,1),XQ(30)=$P(^(0,"GL"),U,2),XQ(31)="AEMQ"
  I $D(^DIC(XQDIC,0,"LAYGO")),DUZ(0)'="@" S Y=$L(^("LAYGO")) I Y F %=1:1 I DUZ(0)[$E(^("LAYGO"),%) G A:%>Y Q
  W !,"WHEN USER SELECTS AN ENTRY IN THE '"_XQ_"' FILE,",!,"WILL ADDING A NEW ENTRY AT THAT TIME ('LAYGO') BE ALLOWED"
- S %=$S(XQ(31)["L":0,1:2) D YN^DICN
- I %=1 I XQ(31)'["L" S XQ(31)=XQ(31)_"L"
- I %=2 I XQ(31)["L" S XQ(31)=$TR(XQ(31),"L")
+ S %=$S($D(^DIC(19,DA,31)):^(31)'["L"+1,1:0) D YN^DICN I %=1 S XQ(31)="AEMQL"
 A Q
  ;
@@ -48,7 +43,5 @@
  G:DUZ0 DIQ1 S DIC("S")="I 1 Q:'$D(^(0,""RD""))  F %=1:1:$L(^(""RD"")) I DUZ(0)[$E(^(""RD""),%) Q"
 DIQ1 ;
- D ^DIC K DIC G:Y<0 Q  S (XQ(80),XQ(30))=$P(^(0,"GL"),U,2)
- S XQ(31)=$G(^DIC(19,DA,31)) S:XQ(31)="" XQ(31)="AEMQ"
- D PUT G Q1
+ D ^DIC K DIC G:Y<0 Q S XQ(31)="AEMQ",(XQ(80),XQ(30))=$P(^(0,"GL"),U,2) D PUT G Q1
  ;
 NAME ;
@@ -67,14 +60,14 @@
 PRNT W !,?16,"*** IMPORTANT PLEASE READ ***",!
  W !,"By selecting a new Print/Sort Template below, your defaults will"
- W !,"be changed. Your defaults are currently set as follows (see below)."
+ W !,"be changed. Your defaults are currently set as follows(see below)."
  W !,"Should you desire to keep the defaults as they are, or to revise"
  W !,"one or more, enter an '^' up-arrow, without selecting a new"
  W !,"template name."
  W !!,?23,"Default Values",!,?23,"==============",!
- W !,?5,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
+ W !,?17,"DIC {DIP}: "_$$GET1^DIQ(19,DA,60)
  W ?40,"L.: "_$$GET1^DIQ(19,DA,62)
- W !,?5,"FLDS: "_$$GET1^DIQ(19,DA,63)
+ W !,?17,"FLDS: "_$$GET1^DIQ(19,DA,63)
  W ?40,"BY: "_$$GET1^DIQ(19,DA,64)
- W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
+ W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
  W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
  Q
@@ -82,11 +75,11 @@
 SORT W !,?16,"*** IMPORTANT PLEASE READ ***",!
  W !,"By selecting a new Sort Template below, your defaults will be"
- W !,"changed. Your defaults are currently set as follows (see below)."
+ W !,"changed. Your defaults are currently set as follow(see below)."
  W !,"Should you desire to keep the defaults as they are, or to revise"
  W !,"one or more, enter an '^' up-arrow, without selecting a new Sort"
  W !,"Template."
  W !!,?23,"Default Values",!,?23,"==============",!
- W ?5,"BY: "_$$GET1^DIQ(19,DA,64)
- W !,?5,"FR: "_$$GET1^DIQ(19,DA,65)
+ W ?17,"BY: "_$$GET1^DIQ(19,DA,64)
+ W !,?17,"FR: "_$$GET1^DIQ(19,DA,65)
  W ?40,"TO: "_$$GET1^DIQ(19,DA,66),!!
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ55.m	(revision 636)
@@ -1,5 +1,4 @@
-XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION [4/12/04 4:36am] ;1/29/08  09:50
- ;;8.0;KERNEL;**140,342,483**;Jul 10, 1995;Build 15
- ;;Per VHA Directive 2004-038, this routine should not be modified
+XQ55 ; SEA/AMF,MJM,JLI - SEARCH FOR USERS ACCESS TO AN OPTION [4/12/04 4:36am]
+ ;;8.0;KERNEL;**140,342**;Jul 10, 1995
 INIT ;
  S XQDSH="-------------------------------------------------------------------------------"
@@ -8,5 +7,5 @@
 MPAT W !!,"Show menu paths" S %=2 D YN^DICN G:%<0 OUT S XQMP=2-% I '% W !!,"If you answer 'YES', the listing will include the menu path(s) each user has",!,"to access the specified option." G MPAT
  K ^TMP($J),XQR,XQP
- S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"'  ["_$P(K,U,1)_"]",XQSCD=0,XQCOM=0,XQNOPRNT=0
+ S K=^DIC(19,XQOPT,0),XQHDR="Access to '"_$P(K,U,2)_"'  ["_$P(K,U,1)_"]",XQSCD=0
 LOOP1 S K=XQOPT,(L,X(0))=0,XQD=K K XQR,XQA,XQK,XQRV S XQR(K)="" I '$L($P(^DIC(19,K,0),U,3)) D TREE1
  G LOOP2
@@ -26,41 +25,21 @@
 LOOP2 ;
  S XQPA(0)=0,XQP=0 F  S XQP=$O(^TMP($J,XQP)) Q:XQP=""  S XQN=^TMP($J,XQP,0) S XQPS="AP" D USERS S XQPS="AD" D USERS
- D USERS1 I XQNOPRNT G MUS ; 080115 - add in options from the common menu
  G LOOP3
 USERS ;
  S XQU=0 F  S XQU=$O(^VA(200,XQPS,XQP,XQU)) Q:XQU'>0  I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU) D EACHU
  Q
-USERS1 ; 080115 code added to handle options on the COMMON (XUCOMMAND) menu
- N XUCOMMON
- S XUCOMMON=$O(^DIC(19,"B","XUCOMMAND",0))
- S XQP=0 F  S XQP=$O(^TMP($J,XQP)) Q:XQP=""  S XQN=^TMP($J,XQP,0) F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  I $P($P(^TMP($J,XQP,J),U,2),",")=XUCOMMON D
- . D  Q:'Y
- . . W !,"***"
- . . W !,"*** This option is available from the 'SYSTEM COMMAND OPTIONS'  ***"
- . . W !,"*** (XUCOMMAND) menu available to all active users unless       ***"
- . . W !,"*** protected by a KEY - DO YOU REALLY WANT THE ENTIRE LIST     ***"
- . . W !,"*** OF THESE USERS???                                           ***",!
- . . N DIR S DIR(0)="Y" D ^DIR S:'Y XQNOPRNT=1 Q:'Y
- . . Q
- . S XQU=0,XQPS="(C)" F  S XQU=$O(^VA(200,XQU)) Q:XQU'>0  I $D(^VA(200,XQU,.1)),+$$ACTIVE^XUSER(XQU),$$KEYCHECK() S II=1 D SETU
- Q
- ;
 EACHU ;
  S II=1
- F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  I $$KEYCHECK() D SETU ; 080115
+ F J=1:1:XQN Q:'$D(^TMP($J,XQP,J))  D
+ .S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1
+ .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0
+ .S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1
+ .I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0
+ .D:XQGO SETU
  Q
- ;
-KEYCHECK() ; 080115 extracted common code
- ; returns 1 if user has access to the option, 0 if the user does not have access
- S XQK=$P(^TMP($J,XQP,J),U,1),XX=$L(XQK,",")-1,XQGO=1
- I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",('$D(^XUSEC(Y,XQU))) S XQGO=0
- S XQK=$P(^TMP($J,XQP,J),U,3),XX=$L(XQK,",")-1
- I XX F X=1:1:XX S Y=$P(XQK,",",X) I Y'="",($D(^XUSEC(Y,XQU))) S XQGO=0
- Q XQGO
- ;
 SETU ;
  S XQPA=$P(^TMP($J,XQP,J),U,2)
  I '$D(XQPA(XQPA)) S I=XQPA(0)+1,XQPA(0)=I,XQPA(0,I)=XQPA,XQPA(XQPA)=I
- S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1 S:XQPS="(C)" XQPA=XQPA_"(C)",XQCOM=1 ; 080115
+ S XQPA=XQPA(XQPA) S:XQPS="AD" XQPA=XQPA_"(S)",XQSCD=1
  S I=$P(^VA(200,XQU,0),U,1)_U_XQU S:$D(^TMP($J,0,I)) II=$O(^TMP($J,0,I,"A"),-1)+1 S ^TMP($J,0,I,II)=XQPA
  Q
@@ -102,5 +81,4 @@
  F I=1:1:XQPA(0) S K=XQPA(0,I) W !,I,".",?4 F N=1:1 Q:'$L($P(K,",",N))  W:N>1 " ... " W $P(^DIC(19,$P(K,",",N),0),U,1)
  I XQSCD W !,"(S) - secondary menu pathway"
- I XQCOM W !,"(C) - SYSTEM COMMAND OPTIONS (XUCOMMAND) menu pathway"
  Q
 MUS G:X="^" OUT I XQPG,$E(IOST,1)="C" W !!,"Press return when finished viewing " R X:DTIME W @IOF G OUT
@@ -109,4 +87,4 @@
  D ^%ZISC
 KILL K XQDT,XQGO,XQN,XQP,XQR,XQRV,XQOPT,XQPA,XQUI,XQSCD,XQDSH,XQU,N,K,J,X,XQA,XQD,XQHDR,XQK,XQP,XQPS,XQMP,XQPG,XX
- K DIC,I,II,JJ,L,POP,Y,XQNOPRNT I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK)
+ K DIC,I,II,JJ,L,POP,Y I $D(ZTQUEUED),$D(ZTSK),ZTSK>0 K ^%ZTSK(ZTSK)
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQ81.m	(revision 636)
@@ -1,4 +1,4 @@
-XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;12/10/07
- ;;8.0;KERNEL;**81,116,157,253,478**;Jul 10, 1995;Build 3
+XQ81 ;SEA/AMF/LUKE,SF/RWF - Build menu trees ;03/03/2003  10:00
+ ;;8.0;KERNEL;**81,116,157,253**;Jul 10, 1995
 BUILD ;
  ;
@@ -10,8 +10,8 @@
  S XQSTART=$$HTE^XLFDT($H)
  K XQFG W !!,"This option will build menu trees for each primary and secondary menu.",!,"You may build all the trees, or build them selectively, using 'verify'.",!,"Note that the 'compiled menus' will only be built into ^XUTL on this CPU.",!
- S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND1 S XQVE=(Y=1)
- S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND1 S XQBSEC=(Y=1)
- ;
- I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND1 I Y=1 D
+ S DIR(0)="Y",DIR("A")="Do you wish to verify each primary menu",DIR("B")="NO",DIR("??")="XQBUILDTREE-VER" D ^DIR K DIR G:$D(DIRUT) BLDEND S XQVE=(Y=1)
+ S DIR(0)="Y",DIR("A")="Would you like to build secondary menu trees too",DIR("B")="YES",DIR("??")="XQBUILDTREE-SEC" D ^DIR G:$D(DIRUT) BLDEND S XQBSEC=(Y=1)
+ ;
+ I 'XQVE S DIR(0)="Y",DIR("A")="Would you like to queue this job",DIR("B")="YES" D ^DIR K DIR G:$D(DIRUT) BLDEND I Y=1 D
  .S ZTRTN="QUE^XQ81",ZTIO=""
  .S ZTSAVE("XQVE")="",ZTSAVE("XQBSEC")="",ZTSAVE("XQSTART")=""
@@ -24,5 +24,5 @@
  E  S ^DIC(19,"AXQ","P0")=$H L +^DIC(19,"AXQ","P0")
  ;
- I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND1 G:Y'=1 RD2
+ I 'XQVE S DIR(0)="Y",DIR("A")="Do you really wish to run this DIRECTLY (it may take some time)",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) BLDEND G:Y'=1 RD2
  ;
 KIDS ;Entry from KIDS
@@ -251,6 +251,2 @@
  G UNWIND^%ZTER
  Q
- ;
-BLDEND1 ;Quit and clean
- K %,%H,%TG,C,D,DIC,DIR,I,J,K,L,V,XQBSEC,X,Y,Z,XQL,XQN,XQRE,XQK,XQI,XQII,UU,XQH,XQPX,XQSAV,XQXUF,XQ81T,XQDATE,XQSEC,XQVE,XQBLD,XQP,XQR,XQJ
- Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDATA.m	(revision 636)
@@ -1,7 +1,7 @@
-XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;4/9/07  13:39
- ;;8.0;KERNEL;**207,285,443**;Jul 10, 1995;Build 4
+XQALDATA ;ISC-SF/JLI - PROVIDE DATA ON ALERTS ;9/9/03  15:13
+ ;;8.0;KERNEL;**207,285**;Jul 10, 1995
  Q
 GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ;
- N XREF,XVAL,X,X2,X3,I,NCNT ; P443
+ N XREF,XVAL
  S:$G(XQAUSER)'>0 XQAUSER=DUZ
  S:$G(FRSTDATE)'>0 FRSTDATE=0
@@ -9,7 +9,7 @@
  S NCNT=0 K @ROOT
  I FRSTDATE=0 D  Q
- . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0  S X=^(I,0),X3=$G(^(3)),X2=$G(^(2)) D
+ . F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0  S X=^(I,0),X3=$G(^(3)) D
  . . S NCNT=NCNT+1
- . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X,U,7,8)="^ ":"I  ",1:"   ")_$P(X,U,3)_U_$P(X,U,2)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443
+ . . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X,U,7,8)="^ ":"I  ",1:"   ")_$P(X,U,3)_U_$P(X,U,2)
  . S @ROOT=NCNT
  S XREF="R"
@@ -18,5 +18,5 @@
  Q
 GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ;
- N XREF,XVAL,NCNT
+ N XREF,XVAL
  S NCNT=0 K @ROOT
  I $G(PATIENT)'>0 S @ROOT=0 Q
@@ -26,13 +26,11 @@
  Q
 CHKTRAIL ;
- N XQ1,X,X1,X2,X3
- ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL  -- from GETPAT or GETUSER
  F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0  D
- . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X=""
+ . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)) Q:X=""
  . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q
  . I FRSTDATE>0,$P(X,U,2)<FRSTDATE Q
  . I FRSTDATE>0,LASTDATE>0,$P(X,U,2)>LASTDATE Q
  . S NCNT=NCNT+1
- . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X1,U,2,3)="^":"I  ",$P(X1,U,2,3)="":"I  ",1:"   ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443
+ . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G  ",$P(X1,U,2,3)="^":"I  ",$P(X1,U,2,3)="":"I  ",1:"   ")_$P(X1,U)_U_$P(X,U)
  S @ROOT=NCNT
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALDEL.m	(revision 636)
@@ -1,4 +1,4 @@
-XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;4/9/07  15:13
- ;;8.0;KERNEL;**6,24,65,114,174,285,443**;Jul 10, 1995;Build 4
+XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;6/28/04  11:02
+ ;;8.0;KERNEL;**6,24,65,114,174,285**;Jul 10, 1995
  ;;
  Q
@@ -107,5 +107,5 @@
  S XQDAT=$$FMADD^XLFDT(DT,-30)
  F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0  D
- . S X1=$P($G(^XTV(8992.1,XQDEL1,0)),U,2),X2=$P($G(^(0)),U,8)
+ . S X1=$P(^XTV(8992.1,XQDEL1,0),U,2),X2=$P(^(0),U,8)
  . S DA=XQDEL1 I X2="",X1>XQDAT Q
  . I X2>0,DT<X2 Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALERT1.m	(revision 636)
@@ -1,4 +1,4 @@
-XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;4/9/07  14:54
- ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366,443**;Jul 10, 1995;Build 4
+XQALERT1 ;ISC-SF.SEA/JLI - ALERT HANDLER ;9/6/05  15:13
+ ;;8.0;KERNEL;**20,65,114,123,125,164,173,285,366**;Jul 10, 1995
  ;;
  Q
@@ -29,5 +29,5 @@
 SUBLOOP W @IOF
  N XQZ1,XQZ
- S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT  S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3),XQZ4=^(4) D  I XQX'="" D DOIT1
+ S XQK=0 F XQI=0:0 Q:XQX1!XQXOUT  S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI),XQII=^(XQI,1),XQZ=^(2),XQZ1=^(3) D  I XQX'="" D DOIT1
  . I '$D(^XTV(8992,XQAUSER,"XQA",XQII)) S XQX="" K ^TMP("XQ",$J,"XQA",XQI),^TMP("XQ",$J,"XQA1",(999999-XQI))
  . Q
@@ -40,12 +40,12 @@
  ;
 RESTORE ; Restore a deleted message for use
- N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU,X4,LONG
+ N ALERTREF,XTVGLOB,ADUZ,X,X0,X1,X2,TIME,MESG,OPT,TAG,ROU
  S XTVGLOB=$NA(^XTV(8992,DUZ,"XQA"))
  S ADUZ=$O(^XTV(8992,"AXQA",XQAID,0)) I ADUZ>0 S TIME=$O(^(ADUZ,0)) D  I 1
  . M @XTVGLOB@(TIME)=^XTV(8992,ADUZ,"XQA",TIME) K @XTVGLOB@(TIME,2) ; copy alert, kill comment if any
  E  S ALERTREF=$O(^XTV(8992.1,"B",XQAID,0)) Q:ALERTREF'>0  D  ; otherwise rebuild from alert tracking file if possible
- . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2)),X4=$O(^(4,0))
- . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4),LONG=(X4>0)
- . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",LONG:"L",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ")
+ . S X0=^XTV(8992.1,ALERTREF,0),X1=$G(^(1)),X2=$G(^(2))
+ . S TIME=$P($P(X0,U),";",3),MESG=$P(X1,U),OPT=$P(X1,U,2),TAG=$P(X1,U,3),ROU=$P(X1,U,4)
+ . S X=TIME_U_XQAID_U_MESG_U_U_$S(OPT'=""!(ROU'=""):"R",1:"I")_U_U_$S(OPT'="":OPT,TAG'="":TAG,1:"")_U_$S(OPT'="":"",ROU'="":ROU,1:" ")
  . S @XTVGLOB@(TIME,0)=X I $G(X2)'="" S ^(1)=X2
  S ^XTV(8992,"AXQA",XQAID,DUZ,TIME)="",^XTV(8992,"AXQAN",$E($P(XQAID,";"),1,30),DUZ,TIME)=""
@@ -69,5 +69,5 @@
  I XQK=0 S XQALINFO=0 I '$D(XQALFWD) W @IOF
  S XQON="$C(0)",XQOFF="$C(0)" S XQOUT=$P(XQX,U,3) I ($$UP^XLFSTR(XQOUT)["CRITICAL")!($$UP^XLFSTR(XQOUT)["ABNORMAL IMA") D:'$D(XQ1ON) SETREV^XQALERT S XQON=XQ1ON,XQOFF=XQ1OFF ; P285
- S XQK=XQK+1 W !,$J(XQK,2),".",$S(XQZ4:"L",$P(XQX,U,8)=" ":"I",1:" "),"  ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'=""  ; P285
+ S XQK=XQK+1 W !,$J(XQK,2),".",$S($P(XQX,U,8)=" ":"I",1:" "),"  ",@XQON,$E($P(XQX,U,3),1,70),@XQOFF S:$P(XQX,U,8)=" " XQALINFO=XQALINFO+1 D:XQZ1'=""  ; P285
  . W !?8,"Forwarded by: ",$P(^VA(200,+XQZ1,0),U),"  Generated: ",$$DAT8^XQALERT(+$P($P(XQX,U,2),";",3),1)
  . I $P(XQZ1,U,3)'="" W !?8,$P(XQZ1,U,3)
@@ -129,7 +129,6 @@
  ;
 SORT ;Sort and remove display only
- N XQZ,XQZ1,XQZ4,XQI,XQK,XQX,XQJ
- F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)),XQZ4=$O(^(4,0)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D
- . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1,^(4)=XQZ4
+ F XQI=0:0 S XQI=$O(^XTV(8992,XQAUSER,"XQA",XQI)) Q:XQI'>0  S XQX=^(XQI,0),XQZ=$G(^(1)),XQZ1=$G(^(2)) S XQJ=$P(XQX,U,7,8) K:XQJ=U ^XTV(8992,XQAUSER,"XQA",XQI) I XQJ'=U D
+ . S XQACNT=XQACNT+1,XQJ=$S(XQAREV:999999-XQACNT,1:XQACNT),^TMP("XQ",$J,"XQA",XQJ)=XQX,^(XQJ,1)=XQI,^(2)=XQZ,^(3)=XQZ1
  S XQK=0 F XQI=0:0 S XQI=$O(^TMP("XQ",$J,"XQA",XQI)) Q:XQI'>0  S XQK=XQK+1 M ^TMP("XQ",$J,"XQA1",XQK)=^TMP("XQ",$J,"XQA",XQI)
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALMAKE.m	(revision 636)
@@ -1,4 +1,4 @@
-XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;4/9/07  14:03
- ;;8.0;KERNEL;**443**;Jul 10, 1995;Build 4
+XQALMAKE ;ISC-SF.SEA/JLI- HIGH LEVEL SETUP ALERT ;9/23/94  13:28
+ ;;8.0;KERNEL;;Jul 10, 1995
  ;;
 ENTRY ;
@@ -11,5 +11,4 @@
  R !,"Enter ROUTINE name or ENTRY^ROUTINE name: ",X:DTIME S:'$T X=U G:X=U EXIT G:X="" ASKROU S XQAROU=X S X=$S(X'[U:X,1:$P(X,U,2)) G:X="" ASKROU X ^%ZOSF("TEST") I 'Y W !,"Routine '",X,"' not present" G ASKROU
 SETIT ;
- I '$D(XQAROU),'$D(XQAOPT) S DIR(0)="Y",DIR("A")="Do you want to make a long text info only alert" D ^DIR K DIR I Y D LONGTEXT
  W !!,"As currently entered, this alert will display the following text:",!!,XQAMSG
  W !!,"The alert is currently to be delivered to:" S XQAX="" F I=1:1 S XQAX=$O(XQA(XQAX)) Q:XQAX=""  S X=$S(XQAX>0:$P(^VA(200,XQAX,0),U),1:XQAX) W:(I#2) ! W:'(I#2) ?40 W X
@@ -33,7 +32,2 @@
  S XQALDIC=$S("g.G."[$E(X,1,2):3.8,1:200),X=$S(XQALDIC=3.8:$E(X,3,$L(X)),1:X),DIC=XQALDIC,DIC(0)="EMQ" D ^DIC Q:Y'>0  S X=$S(XQALDIC=3.8:"G."_$P(Y,U,2),1:+Y),XQA(X)=""
  Q
- ;
-LONGTEXT ;
- W !,"Enter .EXIT  to terminate input",!
- S COUNT="" F  R X:DTIME Q:X=".EXIT"  S COUNT=COUNT+1,XQATEXT(COUNT)=X W !
- Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET.m	(revision 636)
@@ -1,4 +1,4 @@
-XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;4/10/07  14:06
- ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443**;Jul 10, 1995;Build 4
+XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;6/24/04  13:46
+ ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285**;Jul 10, 1995
  ;;
  Q
@@ -8,5 +8,5 @@
  Q
  ;
-SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID.
+SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID. 
  ; If not successful XQALERR is defined and contains reason for failure.
  K XQALERR
@@ -23,5 +23,4 @@
 REENT() ; Entry for forwarding, etc.
  N RETVAL S RETVAL=1
- K ^TMP("XQAGROUP",$J) ; P443 - clear location for storage of groups processed
  N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT()
  S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,80)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1
@@ -60,5 +59,5 @@
 REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP
  S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1)
- I $D(XQATEXT) S:($D(XQATEXT)#2) XQATEXT(.1)=XQATEXT D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") ; P443 PUT DATA IN XQATEXT INTO ARRAY
+ I $D(XQATEXT) D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT")
  L -^XTV(8992,XQJ)
  K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)=""
@@ -111,5 +110,4 @@
  I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID
  K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0)
- K ^TMP("XQAGROUP",$J) ; P443 - clear global used to track processing of groups
  K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT
  Q RETVAL
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSET1.m	(revision 636)
@@ -1,11 +1,12 @@
-XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;4/9/07  10:26
- ;;8.0;KERNEL;**285,443**;Jul 10, 1995;Build 4
+XQALSET1 ;ISC-SF.SEA/JLI - SETUP ALERTS (OVERFLOW) ;10/20/03  15:03
+ ;;8.0;KERNEL;**285**;Jul 10, 1995
  ;;
  Q
-GROUP ;
+GROUP ; 
  N XQI,XQL,XQL1,XQL2,XQLIST
- S XQL=$E(XQJ,3,$L(XQJ)) ; P443 - changed from code that forced upper case
- I $D(^TMP("XQAGROUP",$J,XQL)) Q  ; P443 group has already been processed - prevent cycling
- S ^TMP("XQAGROUP",$J,XQL)="" ; P443 mark that the group has been seen
+ S XQL="" F XQI=3:1:$L(XQJ) S XQL1=$E(XQJ,XQI) S:XQL1?1L XQL1=$C($A(XQL1)-32) S XQL=XQL_XQL1
+ ;S XQI=$O(^XMB(3.8,"B",XQL,0)) I XQI'>0 S XQL1=$O(^XMB(3.8,"B",XQL)) I $E(XQL1,1,$L(XQL))=XQL S XQL2=$O(^(XQL1)) I $E(XQL2,1,$L(XQL))'=XQL S XQI=$O(^(XQL1,0))
+ ;I XQI>0 F XQL=0:0 S XQL=$O(^XMB(3.8,XQI,1,XQL)) Q:XQL'>0  S XQA(+^(XQL,0))=""
+ ;  Above code replaced to use Fileman calls, also code added to walk through member groups as well  030203 JLI P285
  S XQI=$$FIND1^DIC(3.8,,"X",XQL) Q:XQI'>0
  N XQLIST D LIST^DIC(3.81,","_XQI_",",".01","I",,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
@@ -13,8 +14,6 @@
  . Q
  K @XQLIST,XQLIST D LIST^DIC(3.811,","_XQI_",",".01",,,,,,,,.XQLIST) I XQLIST("ORDER")>0 D
- . N XQAGROUP M XQAGROUP=@XQLIST@("ID") ; P443 - store group list data locally so it is not over written by recursive call to LIST^DIC
- . N XQI F XQI=0:0 S XQI=$O(XQAGROUP(XQI)) Q:XQI'>0  N XQJ S XQJ="G."_XQAGROUP(XQI,.01) D GROUP ; P443 - change to reference XQAGROUP
+ . N XQI F XQI=0:0 S XQI=$O(@XQLIST@("ID",XQI)) Q:XQI'>0  N XQJ S XQJ="G."_^(XQI,.01) D GROUP
  . Q
- K @XQLIST,XQLIST
  K XQA(XQJ)
  D CHEKACTV(.XQA)
@@ -27,5 +26,5 @@
  Q
  ;
-CHEKUSER(XQAUSER) ; Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
+CHEKUSER(XQAUSER) ;SR. Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
  N VALUE
  S VALUE=$$ACTVSURO^XQALSURO(XQAUSER)
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m	(revision 636)
@@ -1,4 +1,4 @@
-XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07  08:35
- ;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4
+XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05  14:26
+ ;;8.0;KERNEL;**366**;Jul 10, 1995
  Q
  ;
@@ -92,5 +92,5 @@
 SURRO11 ;
  S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q
- I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11
+ I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1
  S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q
  S XQALEND=+$$ENDDLG() I XQALEND<0 Q
@@ -104,4 +104,5 @@
  S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT)
  N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0
+ ; ZEXCEPT: XQATEST   (EXTERNAL VALUE - INDICATING TEST BEING RUN)
  D CHEKSUBS^XQALSUR2(XQAUSER)
  S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1
@@ -116,4 +117,5 @@
 DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ;
  N XQALNOW,XQALFM
+ ; ZEXCEPT: XQATEST   (EXTERNAL VALUE - INDICATING TEST BEING RUN)
  S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER
  I XQALXREF>0 D
@@ -129,6 +131,5 @@
  . Q
  I $D(XQALFM) D FILE^DIE("","XQALFM")
- ; ZEXCEPT: XTMUNIT   (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN)
- I XQALSURO>0,'$D(XTMUNIT) D
+ I XQALSURO>0,'$D(XQATEST) D
  . N XQAMESG,XMSUB,XMTEXT
  . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for"
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSURO.m	(revision 636)
@@ -1,4 +1,4 @@
-XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;3/17/08  15:20
- ;;8.0;KERNEL;**114,125,173,285,366,443**;Jul 10, 1995;Build 4
+XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05  15:13
+ ;;8.0;KERNEL;**114,125,173,285,366**;Jul 10, 1995
  ;;
  Q
@@ -16,21 +16,16 @@
  D SURRO1^XQALSUR1(XQAUSER)
  Q
+ ; P366 - optional start and end dates added to permit identification of cyclical surrogates in specific times
 CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
- I '$$ACTIVE^XUSER(XQALSURO) Q "You cannot have an INACTIVE USER ("_XQALSURO_") as a surrogate!" ;P443
- I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!" ; moved in P443
  I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND))
  N XQALSTRT
+ I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!"
  S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
- . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user ("_XQALSURO_") - can't do it!" Q
+ . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user - can't do it!" Q
  . F  S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0  I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q
  . Q
  Q XQALSURO
  ;
-SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; Use SETSURO1 instead
- N XQALVAL ; P443
- S XQALVAL=$$SETSURO1(XQAUSER,XQALSURO,$G(XQALSTRT),$G(XQALEND)) ; P443
- Q
- ;
-SETSUROX(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SETSURO CODE MOVED TO HERE TO PERMIT AN ERROR TO BE GENERATED AT THE OLD ENTRY POINT
+SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR
  N XQALFM,XQALIEN,XQAIENS
  I $G(XQAUSER)'>0 Q
@@ -60,6 +55,5 @@
  S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
  S XMTEXT="XQAMESG("
- ; ZEXCEPT: XTMUNIT   - Defined if unit tests are being run
- D:'$D(XTMUNIT) SENDMESG
+ D:'$D(XQATEST) SENDMESG
  Q
  ;
@@ -80,5 +74,5 @@
  N XQAVAL
  S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
- D SETSUROX(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND)) ; P443
+ D SETSURO(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND))
  Q XQALSURO
  ;
@@ -108,5 +102,7 @@
  ;
  ; P366 - find the latest start time which is now or past or the first one in the future
- S XQANOW=$$NOW^XLFDT() D
+ S XQANOW=$$NOW^XLFDT()
+ ;I $P($G(^XTV(8992,XQAUSER,0)),U,2)'>0 D
+ D
  . S XQAIVAL=0,XQASTR1=0
  . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0  Q:XQASTRT'<XQANOW  S XQASTR1=XQASTRT F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0  D
@@ -124,26 +120,8 @@
  I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D  I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2)
  . N DATE ;   Get Current date/time to check date/times if present
- . ; FOLLOWING LINES MODIFIED IN P443 TO ELIMINATE A STACK ERROR WHEN SURROGATE WAS CIRCULAR
- . ;  Current Date/time past End date for surrogate
- . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW)) D REMVSURO(XQAUSER) Q
- . N XQASURO,XQASURO1 S XQASURO1=+$P(^XTV(8992,XQAUSER,0),U,2)
- . ; REMOVE IF SURROGATE IS USER
- . I XQASURO1=XQAUSER D REMVSURO(XQAUSER) Q
- . N XQALLIST S XQALLIST(XQAUSER)=""
- . ; REMOVE IF CYCLES BACK TO USER - thought about removing inactive, but best to let those be handled by groups for unprocessed alerts
- . F  S XQASURO=$P($G(^XTV(8992,XQASURO1,0)),U,2) Q:XQASURO'>0  Q:'$$ISACTIVE(XQASURO)  S XQASURO1=XQASURO D
- . . I $D(XQALLIST(XQASURO)) D REMVSURO(XQASURO) S XQASURO1=XQAUSER K XQALLIST S XQALLIST(XQAUSER)="" Q
- . . S XQALLIST(XQASURO1)=""
- . . Q
- . ; END OF P443 MODIFICATION
+ . ;  Current Date/time past End date for surrogate or cyclic relationship remove checks for new surrogate
+ . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW))!('$$CYCLIC($P(X,U,2),XQAUSER)) D REMVSURO(XQAUSER)
  . Q
  Q -1
- ;
-ISACTIVE(XQAUSER) ; checks for whether a surrogate relationship is active or not (returns 0 or 1)
- N DATA
- S DATA=$G(^XTV(8992,XQAUSER,0)) Q:$P(DATA,U,2)="" 0  ; NO SURROGATE SPECIFIED
- I $P(DATA,U,3)>0,$P(DATA,U,3)>$$NOW^XLFDT() Q 0  ; START DATE/TIME NOT YET
- I $P(DATA,U,4)>0,$P(DATA,U,4)<$$NOW^XLFDT() Q 0  ; PAST END DATE/TIME
- Q 1
  ;
 ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQARPRT2.m	(revision 636)
@@ -1,4 +1,4 @@
-XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS ;4/9/07  10:16
- ;;8.0;KERNEL;**316,443**;Jul 10, 1995;Build 4
+XQARPRT2 ;DCN/BUF,JLI/OAK-OIFO - LOOKUP PROVIDER ALERTS 25 SEP 98 ;9/3/03  11:15
+ ;;8.0;KERNEL;**316**;Jul 10, 1995
  ;  Based on the original routine AEKALERT
  Q
@@ -13,5 +13,4 @@
  N XQANWID,XQAIEN,XQADATE,XQANODE0,XQACTR,HEADERID,XQATOT
  S HEADERID="User "_$$GET1^DIQ(200,XQADOC_",",.01)_" (DFN="_XQADOC_")"
- U IO
  D HEADER(HEADERID,1)
  S XQAIEN=$O(^XTV(8992.1,"D",XQASDATE-.0000001)) I XQAIEN>0 S XQAIEN=$O(^(XQAIEN,0)) ; find starting point instead of having to work up through x-ref
@@ -20,5 +19,4 @@
  . D PRNTATRK(XQAIEN)
  D HEADER(HEADERID,0)
- D ^%ZISC
  K XQADATE,XQACTR,DATA,DIR,DIRUT,XQADOC,XQAIEN,XQANODE0,XQASDATE,Y
  Q
@@ -47,5 +45,5 @@
  . Q
  ;
- I $D(XQAWORDS)>1,$G(TYPE)="" D
+ I $D(XQAWORDS)>1,$G(TYPE)="" D 
  . S DIR(0)="SO^1:Both Action and Info Only;2:Action Alerts;3:Info Only Alerts",DIR("?",1)="Select whether alerts listed should be alerts involving actions (2), info",DIR("?")="only or text only alerts (3), or both (1)."
  . S DIR("A")="Select Alert Type(s) desired",DIR("B")=1 D ^DIR K DIR S:Y'>0 Y=1 K DIRUT S XQADISP=+Y
@@ -82,6 +80,5 @@
  S XQACTR=XQACTR+2 I XQACTR>(IOSL-4) D  Q:$D(DIRUT)  S XQACTR=0
  . I $D(ZTQUEUED) W @IOF
- . E  U IO(0) S DIR(0)="E" D ^DIR K DIR W !
- . U IO
+ . E  S DIR(0)="E" D ^DIR K DIR W !
  . Q
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK.m	(revision 636)
@@ -1,6 +1,4 @@
-XQCHK ; SEA/MJM - Check security on option # XQCY ;5/20/08
- ;;8.0;KERNEL;**47,110,149,303,427,503**;Jul 10, 1995;Build 2
- ;;"Per VHA Directive 2004-038, this routine should not be modified".
- ;
+XQCHK ; SEA/MJM - Check security on option # XQCY ; [7/19/06 10:45am]
+ ;;8.0;KERNEL;**47,110,149,303,427**;Jul 10, 1995;Build 3
  Q:'$D(XQCY)!(XQCY<1)  S:'$D(XQJMP) XQJMP=0
  I '$D(XQY0) S XQY0=^DIC(19,+XQCY,0)
@@ -18,5 +16,7 @@
  Q
  ;
-OUT K %,%XQI,XQCY0,%Y,XQZ
+OUT ;I XQCY=-2 W !,"Locked...Do you have the key "_$P(XQRT,"^",2)
+ ;I XQCY=-3 W !,"Reversed Locked...Don't you have the key "_$P(XQRT,"^",2)
+ K %,%XQI,XQCY0,%Y,XQZ
  Q
  ;
@@ -67,10 +67,168 @@
  Q %
  ;
+ ;
 ACCESS(%XQUSR,%XQOP) ;Find out if a user has access to a particular option
- Q $$ACCESS^XQCHK3(%XQUSR,%XQOP)
+ ;
+ ;    W $$ACCESS(DUZ,Option IEN) returns:
+ ;
+ ;-1:no such user in the New Person File
+ ;-2: User terminated or has no access code
+ ;-3: no such option in the Option File
+ ;0: no access found in any menu tree the user owns
+ ;
+ ;    All other cases return a 4-piece string stating
+ ;    access ^ menu tree IEN ^ a set of codes ^ key
+ ;
+ ;O^tree^codes^key: No access because of locks (see XQCODES below)
+ ;  where 'tree' is the menu where access WOULD be allowed
+ ;  and 'key' is the key preventing access
+ ;1^OpIEN^^: Access allowed through Primary Menu
+ ;2^OpIEN^codes^: Access found in the Common Options
+ ;3^OpIEN^codes^: Access found in top level of secondary option
+ ;4^OpIEN^codes^: Access through a the secondary menu tree OpIEN.
+ ;
+ ;XQCODES can contain:
+ ;  N=No Primary Menu in the User File (warning only)
+ ;  L=Locked and the user does not have the key (forces 0 in first piece)
+ ;  R=Reverse lock and user has the key (forces 0 in first piece)
+ ;
+ I '$D(^VA(200,%XQUSR,0)) Q -1
+ N %,DT
+ S DT=$$HTFM^XLFDT($H,1)
+ S %=^VA(200,%XQUSR,0) I ($P(%,U,3)="")!($L($P(%,U,11))&($P(%,U,11)'>DT)) Q -2
+ ;
+ ;Convert %XQOP to its IEN if the name is passed
+ I +%XQOP'=%XQOP D
+ .I $D(^DIC(19,"B",%XQOP))<1 S %XQOP=0 Q
+ .E  S %XQOP=$O(^DIC(19,"B",%XQOP,0))
+ .Q
+ I '%XQOP Q -3
+ I '$D(^DIC(19,%XQOP,0)) Q -3
+ ;
+ N XQCODES,XQCOM,XQDIC,XQDONE,XQI,XQJ,XQKEY,XQOK,XQPM,XQRSLT,XQSEC,XQTREE
+ S (%,XQDONE,XQOK)=0,(XQRSLT,XQCODES,XQTREE)=""
+ ;
+ ;
+ ;Look in the user's primary menu tree
+ S XQPM=$P($G(^VA(200,%XQUSR,201)),"^")
+ I 'XQPM S XQCODES=XQCODES_"N"
+ ;
+ ;
+ I XQPM S XQDIC="P"_XQPM I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D
+ .D KEYS
+ .I XQCODES'["L"&(XQCODES'["M") S XQOK=1
+ .Q
+ I XQOK Q "1^"_XQPM_"^"_XQCODES
+ I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQPM_"^"_XQCODES_"^"_XQKEY
+ ;
+ ; Search the common options
+ S XQCOM=$O(^DIC(19,"B","XUCOMMAND",0))
+ S XQDIC="PXU"
+ I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) D
+ .D KEYS
+ .I XQCODES'["L"&(XQCODES'["R") S XQOK=1
+ .Q
+ I XQOK Q "2^"_XQCOM_"^"_XQCODES
+ I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQCOM_"^"_XQCODES_"^"_XQKEY
+ ;
+ ;Check the top level of the secondary options
+ S XQDIC="U"_%XQUSR
+ I $D(^VA(200,%XQUSR,203,0)),$P(^(0),U,4)>0 D
+ .S XQJ=0,XQDONE=0
+ .F XQI=1:1 D  Q:XQDONE
+ ..S XQJ=$O(^VA(200,%XQUSR,203,XQJ))
+ ..I (XQJ'=+XQJ)!('XQJ) S XQDONE=1 Q
+ ..S XQSEC(XQI)=+^VA(200,%XQUSR,203,XQJ,0)
+ ..Q:XQSEC(XQI)'=%XQOP
+ ..D KEYS
+ ..I XQCODES'["L"&(XQCODES'["R") S XQOK=1
+ ..I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQSEC(XQI)_"^"_XQCODES_"^"_XQKEY
+ ..Q
+ .Q
+ I XQOK Q "3^"_%XQOP_"^"_XQCODES
+ ;
+ ;If there are no secondaries quit here
+ I '$D(XQI)&((XQCODES["L")!(XQCODES["R")) Q XQRSLT
+ I '$D(XQI) Q 0
+ ;
+ ;Check each secondary menu tree
+ F XQK=1:1:XQI-1 Q:XQOK  D
+ .S XQDIC="P"_XQSEC(XQK)
+ .Q:'$D(^XUTL("XQO",XQDIC,"^",%XQOP))
+ .S XQTREE=$P(XQDIC,"P",2)
+ .D KEYS
+ .I XQCODES'["L"&(XQCODES'["R") S XQOK=1
+ .I XQRSLT="" I XQCODES["L"!(XQCODES["R") S XQRSLT="0^"_XQTREE_"^"_XQCODES_"^"_XQKEY
+ .Q
+ I XQOK Q "4^"_XQTREE_"^"_XQCODES
+ I XQRSLT]"" Q XQRSLT
+ ;
+ ;We doan find nothing nowhere
+ Q "0^^"_XQCODES
+ ;
+KEYS ;Check for keys, reverse keys...
+ N XQK,XQN,XQOPIQ,KFG
+ D CHCK1^XQCHK1 Q:KFG=1
+ I $D(^XUTL("XQO",XQDIC,"^",%XQOP)) S XQOPIQ=^(%XQOP)
+ E  S XQOPIQ=U_^DIC(19,%XQOP,0)
+ ;
+ I $L($P(XQOPIQ,U,7)) D
+ .S %=$P(XQOPIQ,U,7)
+ .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK=""  D
+ ..I '$D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"L",XQKEY=XQK
+ ..Q
+ .Q
+ ;
+ I $L($P(XQOPIQ,U,17)) D
+ .S %=$P(XQOPIQ,U,17)
+ .F XQN=1:1 S XQK=$P(%,",",XQN) Q:XQK=""  D
+ ..I $D(^XUSEC(XQK,%XQUSR)) S XQCODES=XQCODES_"R",XQKEY=XQK
+ ..Q
+ .Q
+ Q
  ;
 OPACCES ;Entry point for the option that checks to see if a user has
  ;access to a particular option by calling the above function.
- D OPACCES^XQCHK3
+ N %,DIC,X,XQANS,XQCODES,XQK,XQKEY,XQOPT,XQOPN,XQPTR,XQRSLT,XQTREE,XQUSER,XQUSN,Y
+ ;
+ S DIC(0)="AEMNQ",DIC="^VA(200,",DIC("A")="Please enter the user's name: " D ^DIC
+ I $D(DUOUT)!($D(DTOUT)) D KILLFM Q
+ I Y=-1 W !!?5,"Sorry we couldn't find that user in the New Person File.",!
+ E  S XQUSN=+Y,XQUSER=$P(Y,U,2)
+ I Y=-1 D KILLFM Q
+ D KILLFM
+ ;
+ S DIC(0)="AEMNQ",DIC="^DIC(19,",DIC("A")="Please enter the name of the option: " D ^DIC
+ I $D(DUOUT)!($D(DTOUT)) D KILLFM Q
+ I Y=-1 W !!?5,"Sorry we couldn't find that option.",!
+ E  S XQOPN=+Y,XQOPT=$P(Y,U,2)
+ I Y=-1 D KILLFM Q
+ D KILLFM
+ ;
+ S XQANS=$$ACCESS(XQUSN,XQOPN)
+ ;W !,XQANS,!
+ ;
+ S XQRSLT=+XQANS,XQTREE=""
+ S XQPTR=$P(XQANS,U,2) I XQPTR>0 S XQTREE=$P(^DIC(19,$P(XQANS,U,2),0),U)
+ S XQCODES=$P(XQANS,U,3),XQKEY=$P(XQANS,U,4)
+ ;
+ I XQRSLT=-1 W !!?5,"User ",XQUSER," is not in the New Person File."
+ I XQRSLT=-2 W !!?5,"User ",XQUSER," has an active termination date,",!?5,"or no verify code."
+ I XQRSLT=-3 W !!?5,"Option ",XQOPT," is not in the Option File."
+ I XQRSLT=0 D
+ .W !!?5,"User ",XQUSER," does not have access to the option",!?5,XQOPT,"."
+ .I XQCODES["L" W !!?5,"There is a lock somewhere in the menu tree "_XQTREE,!?5,"and the user does not hold the key "_XQKEY_"."
+ .I XQCODES["R" W !!?5,"There is a reverse lock somewhere in the menu tree "_XQTREE,!?5,"and the user holds the key "_XQKEY_"."
+ .Q
+ I XQRSLT=1 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the primary menu ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")."
+ I XQRSLT=2 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the Common Options (XUCOMMAND)."
+ I XQRSLT=3 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"as a top-level secondary menu option."
+ I XQRSLT=4 W !!?5,"User ",XQUSER," has access to the option ",XQOPT,!?5,"through the secondary menu tree ",XQTREE," (",$P(^DIC(19,XQPTR,0),U,2),")."
+ W !
+ ;W !!,%,"  ",XQUSER,"  ",XQOPT
+ Q
+ ;
+KILLFM ;Kill off the FileMan variables
+ K D0,DI,DIC,DIE,DISYS,DQ,DR,DUOUT,DTOUT,X,Y
  Q
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQCHK2.m	(revision 636)
@@ -1,67 +1,16 @@
-XQCHK2 ; OAK-BP/BDT - Internal APIs to check Keys for options; 5/20/08
- ;;8.0;KERNEL;**427,503**;Jul 10, 1995;Build 2
- ;;"Per VHA Directive 2004-038, this routine should not be modified".
- Q
- ;; These Internal Kernel APIs are using in the routine XQCHK
- ;; to check Keys for options
- ;; 
-CHCKL(XQCY0,XQDUZ) ;Entry point for checking all Locks for an option
- ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99)
- ;; XQDUZ is IEN of user
- ;; Return XQRT: Zero or 1^Key found that user needed for the option
- S XQCY0=$G(XQCY0)
+XQCHK2 ; BP/BDT - GET CALL FROM XQCHK ; [7/19/06 10:45am]
+ ;;8.0;KERNEL;**427**;Jul 10, 1995;Build 3
+ ; Entry point for checking all Locks for a option
+CHCKL(XQCY0,DUZ) ;
  N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0
- ;check Key for the option; p457
- S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY)
- I +XQX S XQK=$$GET1^DIQ(19,XQX,3)
- I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT
- ;loop through higher menu options.
  S XQY=$P(XQCY0,"^",5)
  F XQI=1:1  S XQX=$P(XQY,",",XQI) Q:'XQX  D
- . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q
+ . I +XQX S XQK=$$GET1^DIQ(19,XQX,3) I XQK'="",'$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q
  Q XQRT
- ;
-CHCKRL(XQCY0,XQDUZ) ;Entry point for checking all Reversed Locks for an option
- ;; XQCY0 is $P(^XUTL("XQO",XQDIC,"^",%XQOP),"^",2,99)
- ;; XQDUZ is IEN of user
- ;; Return XQRT: Zero or 1^Reversed Key found that user has
- S XQCY0=$G(XQCY0)
+ ; Entry point for checking all Reversed Locks for a option
+CHCKRL(XQCY0,DUZ) ;
  N XQI,XQY,XQX,XQRT,XQK S (XQRT,XQX)=0
- ;check Reversed Key for the option; p457
- S XQY=$P(XQCY0,"^"),XQX=$$GETIEN(XQY)
- I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01)
- I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q XQRT
- ;loop through higher menu options.
  S XQY=$P(XQCY0,"^",5)
  F XQI=1:1  S XQX=$P(XQY,",",XQI) Q:'XQX  D
- . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK Q 
+ . I +XQX S XQK=$$GET1^DIQ(19,XQX,3.01) I XQK'="",$D(^XUSEC(XQK,DUZ)) S XQRT=1_"^"_XQK Q 
  Q XQRT
- ;
-GETIEN(XQNAME) ;get IEN for an option; 457
- ;; XQNAME is name of an option
- ;; Retrun XQIEN: Null or IEN if existed
- N XQIEN S XQIEN=""
- I $G(XQNAME)="" Q XQIEN
- I '$D(^DIC(19,"B",XQNAME)) Q XQIEN
- S XQIEN=$O(^DIC(19,"B",XQNAME,XQIEN))
- Q XQIEN
- ;
-CHKTOPL(XQIEN,XQDUZ) ;Check Lock for the top level of the secondary options
- ;this need to be called to check the top level first when check the
- ;Locks for lower menu option because the 6th piece of ^XUTL does not
- ;contain the IEN of the top menu option.
- N XQRT,XQK S XQRT=0
- I XQIEN'=+$G(XQIEN) Q XQRT
- S XQK=$$GET1^DIQ(19,XQIEN,3)
- I $G(XQK)'="",'$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK
- Q XQRT
- ;
-CHKTOPRL(XQIEN,XQDUZ) ;Check Reversed Lock the top level of the secondary options
- ;this need to be called to check the top level first when check the
- ;Reversed Locks for lower menu option because the 6th piece of ^XUTL does not
- ;contain the IEN of the top menu option.
- N XQRT,XQK S XQRT=0
- I XQIEN'=+$G(XQIEN) Q XQRT
- S XQK=$$GET1^DIQ(19,XQIEN,3.01)
- I $G(XQK)'="",$D(^XUSEC(XQK,XQDUZ)) S XQRT=1_"^"_XQK
- Q XQRT
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR.m	(revision 636)
@@ -1,4 +1,20 @@
-XQOR ; SLC/KCM - Prepare to Unwind Options ;5/24/94  17:58 ;
- ;;8.0;KERNEL;**48,56**;Jul 10, 1995
+XQOR ; SLC/KCM - Prepare to Unwind Options ;4/3/07  16:21
+ ;;8.0;KERNEL;**48,56,437**;Jul 10, 1995;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  S DIC=19,DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0  S X=+Y_";DIC(19,"
 EN ;Process options/protocols from top
@@ -12,5 +28,8 @@
  S XQORNEST(XQORS)=^TMP("XQORS",$J,XQORS,"VPT"),XQORNEST=XQORS
  G:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)")) EX S ^TMP("XQORS",$J,XQORS,"FLG")=$P(^(0),"^",4)_"^^" G:$P(^TMP("XQORS",$J,XQORS,"FLG"),"^")'?1A EX
- I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX
+ ; LOCAL MOD VWSD SILENTMODE ECHO SDAM EVENTS (VARIABLE XQORMUTE)
+ I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W:'$D(ZTSK)&'$D(XQORMUTE) !!,$P(^(0),"^",3),! D:'$D(ZTSK)&'$D(XQORMUTE) READ^XQOR4 G EX
+ ;I $L($P(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),"^",3)) W !!,$P(^(0),"^",3),! D READ^XQOR4 G EX
+ ;END LOCAL MODE
  D C19^XQOR4 G:Y<0 EX
  S ^TMP("XQORS",$J,0,"FILE")=";"_$P(^TMP("XQORS",$J,XQORS,"VPT"),";",2),^TMP("XQORS",$J,XQORS,"INP")=""
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQOR4.m	(revision 636)
@@ -1,4 +1,20 @@
-XQOR4 ; SLC/KCM - Process "^^" jump ;11/18/92  09:53 ;
- ;;8.0;KERNEL;**56,62**;Jul 10, 1995
+XQOR4 ; SLC/KCM - Process "^^" jump ;1/23/07  15:36
+ ;;8.0;KERNEL;**56,62,437**;Jul 10, 1995;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 DJMP ;From: STAK^XQOR1
  Q:'$D(^TMP("XQORS",$J,XQORS,"ITM",^TMP("XQORS",$J,XQORS,"ITM"),"IN"))
@@ -21,5 +37,8 @@
  Q:'$D(@(^TMP("XQORS",$J,XQORS,"REF")_"0)"))  S X=$P(^(0),"^",2) W:X'?1." " !!?(36-($L(X)\2)),"--- "_X_" ---"
  Q
-READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300)
+ ;VWSD LOCAL MOD STARTED HERE, XQ SILENT MODE . VARIABLE XQORMUTE
+READ I '$D(XQORMUTE) W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300)
+ ;READ W !,"Press RETURN to continue: " R X:$S($D(DTIME):DTIME,1:300)
+ ;END LOCAL MOD
  Q
 C19 N X0 S X0=@(^TMP("XQORS",$J,XQORS,"REF")_"0)"),X=$P(X0,"^",6) I $L(X),'$D(^XUSEC(X,DUZ)) W !!,"This option "_$P(X0,"^")_" is locked.",! D READ S Y=-1 Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC ; DRIVER FOR COMPILED XREFS FOR FILE #101 ; 10/15/04
+XQORC ; DRIVER FOR COMPILED XREFS FOR FILE #101 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC1.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC1 ; COMPILED XREF FOR FILE #101 ; 10/15/04
+XQORC1 ; COMPILED XREF FOR FILE #101 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC10.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC10.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC10.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC10 ; COMPILED XREF FOR FILE #101.02 ; 10/15/04
+XQORC10 ; COMPILED XREF FOR FILE #101.02 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC11.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC11.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC11.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC11 ; COMPILED XREF FOR FILE #101.021 ; 10/15/04
+XQORC11 ; COMPILED XREF FOR FILE #101.021 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC12.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC12.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC12.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC12 ; COMPILED XREF FOR FILE #101.03 ; 10/15/04
+XQORC12 ; COMPILED XREF FOR FILE #101.03 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC13.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC13.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC13.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC13 ; COMPILED XREF FOR FILE #101.07 ; 10/15/04
+XQORC13 ; COMPILED XREF FOR FILE #101.07 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC14.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC14.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC14.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC14 ; COMPILED XREF FOR FILE #101.0775 ; 10/15/04
+XQORC14 ; COMPILED XREF FOR FILE #101.0775 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC2.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC2 ; COMPILED XREF FOR FILE #101.01 ; 10/15/04
+XQORC2 ; COMPILED XREF FOR FILE #101.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC3.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC3.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC3.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC3 ; COMPILED XREF FOR FILE #101.02 ; 10/15/04
+XQORC3 ; COMPILED XREF FOR FILE #101.02 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC4.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC4.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC4.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC4 ; COMPILED XREF FOR FILE #101.021 ; 10/15/04
+XQORC4 ; COMPILED XREF FOR FILE #101.021 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC5.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC5.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC5.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC5 ; COMPILED XREF FOR FILE #101.03 ; 10/15/04
+XQORC5 ; COMPILED XREF FOR FILE #101.03 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC6.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC6.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC6.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC6 ; COMPILED XREF FOR FILE #101.07 ; 10/15/04
+XQORC6 ; COMPILED XREF FOR FILE #101.07 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC7.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC7.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC7.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC7 ; COMPILED XREF FOR FILE #101.0775 ; 10/15/04
+XQORC7 ; COMPILED XREF FOR FILE #101.0775 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC8.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC8.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC8.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC8 ; COMPILED XREF FOR FILE #101 ; 10/15/04
+XQORC8 ; COMPILED XREF FOR FILE #101 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC9.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC9.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQORC9.m	(revision 636)
@@ -1,3 +1,3 @@
-XQORC9 ; COMPILED XREF FOR FILE #101.01 ; 10/15/04
+XQORC9 ; COMPILED XREF FOR FILE #101.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQSUITE.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQSUITE.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQSUITE.m	(revision 636)
@@ -1,4 +1,21 @@
 XQSUITE ;Luke/Sea - Window Suite driver ;2/14/95  10:32
- ;;8.0;KERNEL;;Jul 10, 1995
+ ;;8.0;KERNEL;;Jul 10, 1995;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  ;Jump-start XQSUITE by asking which suite to run
@@ -134,5 +151,5 @@
  .D GET^XGCLOAD(XQSUI,$NA(^TMP($J,XQWIN)))
  .D M^XG(XQWIN,$NA(^TMP($J,XQWIN)))
- .D SD^XG($PD,"FOCUS",XQWIN)
+ .D SD^XG($P,"FOCUS",XQWIN)
  .;D ESTA^XG() ;Send it off to window land
  .; 
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUP.m	(revision 636)
@@ -1,6 +1,6 @@
-XUP ;SFISC/RWF - Setup enviroment for programmers ;10/12/06  12:45
- ;;8.0;KERNEL;**208,258,284,432**;Jul 10, 1995;Build 3
+XUP ;SFISC/RWF - Setup enviroment for programmers ;09/21/2004  16:35
+ ;;8.0;KERNEL;**208,258,284**;Jul 10, 1995
  W !,"Setting up programmer environment"
- S U="^",$ECODE="",$ETRAP="" ;Clear error and error trap
+ N $ESTACK,$ETRAP S $ECODE="",$ETRAP="" ;Clear and error trap
  X ^%ZOSF("TYPE-AHEAD")
  ;Check if Production and report
@@ -14,10 +14,8 @@
  I $D(DUZ("SAV")) S DUZ=+DUZ("SAV"),DUZ(0)=$P(DUZ("SAV"),U,2) K DUZ("SAV")
  ;Get user info
- I $G(DUZ)>.5,$D(^VA(200,DUZ,0))[0 K DUZ W !,"DUZ Must point to a real user." G EXIT ;p432
  I $G(DUZ)>0 D DUZ(DUZ)
  I $G(DUZ)'>0!('$D(DUZ(0))) D ASKDUZ G:Y'>0 EXIT
  I '$D(XQUSER) S XQUSER=$S($D(^VA(200,DUZ,20)):$P(^(20),"^",2),1:"Unk")
  S DTIME=600 ;Set a temp DTIME
- S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p432
  ;Getting Terminal Type
 ZIS I XUTT D ENQ^XUS1 G:$D(XUIOP(1)) ZIS2 S Y=0 D TT^XUS3 I Y>0 S XUIOP(1)=$P(XUIOP,";",2) G ZIS2
@@ -33,40 +31,32 @@
  I $$GET^XPAR("USR^SYS","XUS-XUP SET ERROR TRAP",1,"Q") S $ETRAP="D ERR^XUP"
  D KILL1^XUSCLEAN S $P(XQXFLG,U,3)="XUP" D ^XQ1
-EXIT ;Clean-up and exit
- D KILL1^XUSCLEAN K XQY,XQY0
- I $G(DUZ)>0,$$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
+EXIT D KILL1^XUSCLEAN K XQY,XQY0
+ I $$GET^XPAR("USR^SYS","XUS-XUP VPE",1,"Q"),$D(^%ZVEMS) X ^%ZVEMS ;Run VPE
  Q
  ;
-ASKDUZ ;Ask for Access Code
- N X
- ;X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
- X XUEOFF W !,"Access Code: " S X=$$ACCEPT^XUS() X XUEON
- I X["^"!('$L(X)) S Y=-1 Q
+ASKDUZ X XUEOFF S DIR(0)="FO",DIR("A")="Access Code" D ^DIR W ! X XUEON I $D(DIRUT) S Y=-1 Q
  S X=$$UP^XLFSTR(X) S:X[":" XUTT=1,X=$P(X,":",1)_$P(X,":",2)
  D ^XUSHSH S Y=$O(^VA(200,"A",X,0))
- K DUZ D DUZ(+Y)
- Q
+ K DUZ D DUZ(+Y) Q
  ;
 DUZ(DA) ;Build DUZ for a user.  Used by Mailman.
  ;(p284) Make the setting of several DUZ parts conditional.
- N Y
- S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS"))
+ N Y S Y(0)=$G(^VA(200,+DA,0)),Y("XUS")=$G(^XTV(8989.3,1,"XUS"))
  S DUZ=DA
  S:$G(DUZ(0))'="@" DUZ(0)=$P(Y(0),"^",4)
  S DUZ(1)="",DUZ("AG")=$P($G(^XTV(8989.3,1,0)),"^",8)
  S:'$G(DUZ(2)) DUZ(2)=$O(^VA(200,DUZ,2,0))
- S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),"^",17)
- S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),"^",7)
+ S:'DUZ(2) DUZ(2)=+$P(Y("XUS"),U,17)
+ S:'$L($G(DUZ("LANG"))) DUZ("LANG")=$P(Y("XUS"),U,7)
  Q
  ;
 DTIME(E,D) ;Return DTIME value for user E, device D.
- N P
- S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10)
+ N P S P=$P($G(^VA(200,+$G(E),200)),"^",10) S:P="" P=$P($G(^%ZIS(1,+$G(D),"XUS")),"^",10) S:P="" P=$P($G(^XTV(8989.3,1,"XUS")),"^",10)
  Q $S(P]"":P,1:300)
  ;
 ERR ;
- N %XUP U $P
+ U $P
  W !,"$ECODE=",$ECODE,"   $STACK=",$STACK
- W !,"Location: ",$STACK($STACK-1,"PLACE")
  R !!,"Want to record the error: No// ",%XUP:600 I "Yy"[$E(%XUP_"N") D ^%ZTER
  D UNWIND^%ZTER ;S:'$ESTACK $ECODE="" S $ETRAP="" Q:$QUIT "" Q
+ ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPROD.m	(revision 636)
@@ -1,4 +1,4 @@
-XUPROD ;ISF/RWF - Is this a PROD account. ;8/23/07  16:47
- ;;8.0;KERNEL;**284,440**;Jul 10, 1995;Build 13
+XUPROD ;ISF/RWF - Is this a PROD account. ;06/17/2004  08:13
+ ;;8.0;KERNEL;**284**;Jul 10, 1995
  ;
  ;IA# 4440
@@ -32,9 +32,8 @@
  N DIR,P S P=$$PROD
  S DIR(0)="YO",DIR("A")="Is this a Production Account",DIR("B")="No"
- S DIR("A",1)=""
- S DIR("A",2)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account."
- S DIR("A",3)=" "
- S DIR("A",4)="Only answer YES if this is the full time Production Account."
- S DIR("A",5)="Answer No for all other accounts."
+ S DIR("A",1)="This is now a "_$S(P:"PRODUCTION",1:"TEST")_" account."
+ S DIR("A",2)=" "
+ S DIR("A",3)="Only answer YES if this is the full time Production Account."
+ S DIR("A",4)="Answer No for all other accounts."
  D ^DIR Q:$D(DIRUT)
  I Y=1 D SSID($$SID^%ZOSV)
@@ -43,10 +42,2 @@
  W:P !!,"This is now a PRODUCTION account.",! W:'P !!,"This is now a TEST account.",!
  Q
- ;
-EDIT ;Edit Logical - Physical fields
- N DIE,DA,DR
- W !!,"This is only valid in a Cache v5.2 client/server configuration."
- W !,"This lets you edit the fields that support the"
- W !,"LOGICAL to PHYSICAL translation for the System ID.",!!
- S DA=1,DIE="^XTV(8989.3,",DR="504;505" D ^DIE
- Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS.m	(revision 636)
@@ -1,4 +1,20 @@
-XUS ;SFISC/STAFF - SIGNON ;2/13/07  14:44
- ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,434**;Jul 10, 1995;Build 6
+XUS ;SFISC/STAFF - SIGNON ;3/19/07  09:15
+ ;;8.0;KERNEL;**16,26,49,59,149,180,265,337,419,437**;Jul 10, 1995;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Sign-on message numbers are 30810.51 to 30810.99
  S U="^" D INTRO^XUS1A()
@@ -80,5 +96,5 @@
  . Q
  Q A
- ;
+ ; 
 CHECKAV(X1) ;Check A/V code return DUZ or Zero. (Called from XUSRB)
  N %,%1,X,Y,IEN,DA,DIK
@@ -90,8 +106,8 @@
  . Q
  ;End CCOW
- S X1=$$UP(X1) S:X1[":" XUTT=1,X1=$TR(X1,":")
+ S X1=$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):$$UP($P(X1,";",1))_";"_$P(X1,";",2),1:$$UP(X1)) S:X1[":" XUTT=1,X1=$TR(X1,":") ; Allow case sensitive for VOE
  S X=$P(X1,";") Q:X="^" -1 S:XUF %1="Access: "_X
  Q:X'?1.20ANP 0
- S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0
+ S X=$$EN^XUSHSH(X) I '$D(^VA(200,"A",X)) D LBAV Q 0 ; Case insensitive for Access Code for VOE
  S %1="",IEN=$O(^VA(200,"A",X,0)),XUF(.3)=IEN D USER(IEN)
  S X=$P(X1,";",2) S:XUF %1="Verify: "_X S X=$$EN^XUSHSH(X)
@@ -121,8 +137,8 @@
  N %
  S U="^",XUEON=^%ZOSF("EON"),XUEOFF=^("EOFF")
- D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) ;S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
+ D XUVOL,XOPT S DUZ("LANG")=$P(XOPT,U,7) S:$P(XUVOL,U,6)="y" XRTL=XUCI_","_XQVOL
  K ^XUTL("XQ",$J) S XUF=0,XUDEV=0,DUZ=0,DUZ(0)="@",IOS=0,ION=""
  I FLAG S %ZIS="L",IOP="HOME" D ^%ZIS Q:POP
- S XUDEV=IOS,XUIOP=ION
+ S XUDEV=IOS,XUIOP=ION D:$D(XRTL) T0^%ZOSV
  D GETFAC^XUS3($G(IO("IP")))
  S %=$P(XOPT,U,14)
@@ -130,5 +146,4 @@
  . S XUF=(%["R")+1,XUF(.1)="",XUF(.2)=0,XUF(.3)=0
  . I %["D" S:$D(^XTV(8989.3,1,4.33,"B",XUDEV))[0 XUF=0
- S DILOCKTM=+$G(^DD("DILOCKTM"),1) ;p434 IA#4909
  Q
 SET2() ;EF. Return error code (also called from XUSRB)
@@ -142,4 +157,5 @@
  S DTIME=600
  I '$P(XOPT,U,11),$D(^%ZIS(1,XUDEV,90)),^(90)>2800000,^(90)'>DT Q 8
+ I $D(XRT0) S XRTN="XUS" D T1^%ZOSV
  Q 0
  ;
@@ -148,7 +164,6 @@
  I $P(XUSER(1.1),U,5),$P(XUSER(1.1),U,5)>XUNOW S XUM(0)=$$FMTE^XLFDT($P(XUSER(1.1),U,5),"2PM") Q 18 ;User locked until
  I $P(XUSER(0),U,11),$P(XUSER(0),U,11)'>DT Q 11 ;Access Terminated
- I $D(DUZ("ASH")) Q 0 ;If auto handle, Allow to sign-on p434
  I $P(XUSER(0),U,7) Q 5 ;Disuser flag set
- I '$L($P(XUSER(1),U,2)) Q 21 ;p419, p434
+ I '$L($P(XUSER(1),U,2)) Q 21 ;419
  Q 0
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUS2.m	(revision 636)
@@ -1,5 +1,21 @@
-XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;11/29/2006
- ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 2
+XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/3/07  19:18
+ ;;8.0;KERNEL;**59,180,313,419,437**;Jul 10, 1995;Build 22
  Q
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
 ACCED ; ACCESS CODE EDIT from DD
@@ -44,5 +60,5 @@
 GET ;Get the user input and convert case.
  S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT
- S X=$$UP^XLFSTR(X)
+ I '$D(ASKINGVC)!'$$GET^XPAR("SYS","XU VC CASE SENSITIVE") S X=$$UP^XLFSTR(X) ;for VOE allow case sensitive Verify Code
  Q
  ;
@@ -65,8 +81,8 @@
  ;Fall into next code
 VERED ; VERIFY CODE EDIT From DD
- N DIR,DIR0,XUAUTO
+ N DIR,DIR0,XUAUTO,ASKINGVC
  I "Nn"[$E(X,1) S X="" Q
  I "Yy"'[$E(X,1) K X Q
- S XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin
+ S ASKINGVC=1,XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin
 VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1)
  D CALL^XUSERP(DA,2)
@@ -84,5 +100,6 @@
  N PUNC,NA S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/"
  S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA)
- I ($L(S)<8)!($L(S)>20)!(S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
+ ; for VOE allow case sensitive Verify Code with S'?.ANP
+ I ($L(S)<8)!($L(S)>20)!$S($$GET^XPAR("SYS","XU VC CASE SENSITIVE"):S'?.ANP,1:S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
  I (S?8.20A)!(S?8.20N)!(S?8.20P)!(S?8.20AN)!(S?8.20AP)!(S?8.20NP) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation."
  I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one."
@@ -110,5 +127,5 @@
  ;
 AGEN ;Generate a ACCESS code
- S XUU=$$AC^XUS4 S (X,XUH)=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN
+ S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN
  D CLR W "The new ACCESS CODE is: ",XUU,"   This is ",XUK," of 3 tries."
  D YN
@@ -129,5 +146,5 @@
  ;
 VGEN ;Generate a VERIFY code
- S XUU=$$VC^XUS4 S (X,XUH)=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN
+ S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU),XUH=X I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN
  D CLR W "The new VERIFY CODE is: ",XUU,"   This is ",XUK," of 3 tries."
  D YN
@@ -135,9 +152,6 @@
 YN ;Ask if want to keep
  N DIR
- S Y=1,DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!"
- S:XUK=3 DIR("A")="This is your final choice. "_DIR("A")
- D ^DIR Q:(Y=1)!$D(DIRUT)  I XUK=2 W !,"O.K. You'll have to keep the next one!",! H 2
- I (XUK=3)&(Y'=1) W !,"Lets stop and you can try later." H 3 D DIRUT
- D CLR
+ S Y=1 Q:XUK=3  S DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!"
+ D ^DIR Q:(Y=1)!$D(DIRUT)  D CLR W:XUK=2 "O.K. You'll have to keep the next one!",!
  Q
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSCLEAN.m	(revision 636)
@@ -1,4 +1,4 @@
-XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;10/26/06  08:12
- ;;8.0;KERNEL;**13,59,165,353,434**;Jul 10, 1995;Build 6
+XUSCLEAN ;SF/STAFF - CLEANUP BEFORE EXIT ;05/26/2005  14:28
+ ;;8.0;KERNEL;**13,59,165,353**;Jul 10, 1995;Build 1
 H ;;Exit point for all R/S applications
  LOCK  ;Unlock any locks
@@ -19,5 +19,5 @@
 H2 ;No talking after this point
  D C,XUTL
- ;un-comment the following line if you want FM space recall cleared
+ ;un-comment the following line if you want FM space recall cleared 
  ;after each session.
  ;K ^DISV($G(DUZ,0))
@@ -78,12 +78,10 @@
 KILL1 ;To clean up ALL but kernel variables.
  I $$BROKER^XWBLIB S %2=$P($T(VARLST^XWBLIB),";;",2) I %2]"" N @%2 ;Protect Broker variables.
- N XGWIN,XGDI,XGEVENT ;P434 remove KWAPI
+ N KWAPI,XGWIN,XGDI,XGEVENT
  N XQAEXIT,XQAUSER,XQX1,XQAKILL,XQAID
- ;p434 add DILOCKTM, remove XRTL, %ZH0
- K (DUZ,DTIME,DILOCKTM,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ)
+ K (DUZ,DTIME,DT,DISYS,IO,IOBS,IOF,IOM,ION,IOSL,IOST,IOT,IOS,IOXY,U,XRTL,%ZH0,XQVOL,XQY,XQY0,XQDIC,XQPSM,XQPT,XQAUDIT,XQXFLG,ZTSTOP,ZTQUEUED,ZTREQ)
  K IO("C"),IO("Q")
  Q
  ;
 XMR ;Entry point from XUS to DO xmr and cleanup after.
- N XQXFLG ;p434
  D NEXT^XUS1 S XQXFLG="",XQXFLG("HALT")=1 G H2
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSERBLK.m	(revision 636)
@@ -1,28 +1,22 @@
-XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS  ;02/26/2008
- ;;8.0;KERNEL;**20,214,230,289,419,490**;Jul 10, 1995;Build 5
- ; Per VHA Directive 2004-038, this routine should not be modified.
- ; Option: XUSERBLK
+XUSERBLK ;SF/RWF - Bulk user (new person) COMPUTER ACCESS  ; 5/23/2006
+ ;;8.0;KERNEL;**20,214,230,289,419**;Jul 10, 1995;Build 5
  ; This routine allows the Cloning of one person to a group of others.
 A ;
  I $G(DUZ)'>0 W !!,"You are not a known user and can't use this option." Q
- N DIC,X,Y,XUTMP,DA,DIR,XUTERMDT,XUSER,XUY,%ZIS,XUIOP,XMQUIET
+ N DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU
  K ^TMP($J)
 B1 W @IOF,!?26,"Batch Entry of New Persons"
  W !?26,"--------------------------",!!,"Please select a person to copy from"
  K DIC S DIC(0)="AEQZ",DIC("A")="Template PERSON: ",DIC="^VA(200," D ^DIC
- Q:$D(DTOUT)!$D(DUOUT)
- G B1:Y=-1
+ G QUIT:$D(DTOUT)!$D(DUOUT),B1:Y=-1
  ; Show INFO to be copied"
  S XUTMP=+Y,XUTMP(0)=$P(Y,U,2),DA=+Y D EN^DIQ
- S DIR(0)="Y",DIR("A")="Is this the person whose data you want cloned" D ^DIR Q:$D(DIRUT)  G B1:'Y
- W !!,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
- S DIR(0)="DAO^DT::AEF"
- S DIR("A")="Enter (optional) TERMINATION DATE: "
- D ^DIR Q:$D(DTOUT)!$D(DUOUT)
- S XUTERMDT=Y
+ S DIR(0)="Y",DIR("A")="Is this the person data you want cloned" D ^DIR G B1:'Y
+ W !,"You may enter a date, when the users that are being created/updated",!,"will no longer have access to the system."
+ S XUTERMDT="",%DT="AEF",%DT(0)=DT,%DT("A")="Enter (optional) TERMINATION DATE: " D ^%DT S:Y>0 XUTERMDT=Y
  K XUSER S XUSER=0
 B2 ;
  W !!,?26,"Batch Entry of New Persons",!,?26,"--------------------------",!
- W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?49,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
+ W !,"Clone of: ",XUTMP(0) I XUTERMDT W ?50,"TERMINATION DATE: ",$$FMTE^XLFDT(XUTERMDT)
  ;;
 B3 F  S XUY=$$ADD^XUSERNEW Q:XUY<0  D  ;Create new entry
@@ -35,35 +29,29 @@
  . . S DIR(0)="Y",DIR("A")="Do You Want To Clone PERSON CLASS" D ^DIR
  . . S:Y=1 $P(XUY,U,5)=1
- . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !!,"Next!"
+ . S:XUY>0 XUSER=XUSER+1,XUSER(XUSER)=XUY W !,"Next!",!
  . Q
 B4 ;
- Q:XUSER'>0
- I XUTERMDT D
- . N XUZT
- . S XUZT("ZTDTH")=XUTERMDT
- . W !!,"Queueing automatic deactivation for ",$$FMTE^XLFDT(XUTERMDT)
- . S X=$$NODEV^XUTMDEVQ("CHECK^XUSTERM1",,,.XUZT,1)
- W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS?"
- S XMQUIET=1
- S %ZIS="NMQ" D ^%ZIS Q:POP  ; "N" means don't open device
- K XMQUIET
- S XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
- D HOME^%ZIS
- ;I ION["P-MESSAGE-HFS" G START
+ G:XUSER'>0 QUIT
+ I XUTERMDT>0 S ZTRTN="CHECK^XUSTERM1",ZTIO="",ZTDTH=XUTERMDT D ^%ZTLOAD W !,"Automatic deactivation has been queued for this date.",!
+ W !!,"Where do you want to print the COMPUTER ACCOUNT NOTIFICATION LETTERS"
+ S %ZIS="MQ" D ^%ZIS G QUIT:POP
+ I ION["P-MESSAGE-HFS" G START
  I '$D(IO("Q")) G CLONE
 START ;
- N XUZT
- S XUZT("ZTDTH")=$H
- S X=$$NODEV^XUTMDEVQ("CLONE^XUSERBLK",,"XUIOP;XUTMP;XUTERMDT;XUSER;XUSER(",.XUZT,1)
+ S ZTRTN="CLONE^XUSERBLK" F I="XUTMP","XUTERMDT","XUSER","XUSER(" S ZTSAVE(I)=""
+ K IO("Q") D ^%ZTLOAD
+ ;;
+QUIT ;
+ K DIC,DIR,%,L,XUIOP,XUNODE,XU1,X1,X2,X3,X4,X5,X6,XUTEXT,XUNEW,XUSER,XUTMP,XUTERMDT,XUH,XUU,XUU2,M,P,XU
+ K ^TMP($J)
  Q
  ;;
 CLONE ;;Do work
- N XUTEXT,XU1,%,DA,XUNEW,XUPURGE
- S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0))
+ S XUTEXT=$O(^DIC(9.2,"B",$$GET^XUPARAM("XUSER COMPUTER ACCOUNT","N"),0)),XUIOP=ION_";"_IOST_";"_IOM_";"_IOSL
  F XU1=1:1:XUSER S %=XUSER(XU1),DA=+%,XUNEW=$P(%,U,3),XUPURGE=$P(%,U,4) D C2,UPDATE("ORD",DA)
- K ^TMP($J)
- Q
+ G QUIT
+ ;
 C2 ;
- N XUU,XUU2,XFDA,XUH,XUH2,XIEN,XERR,Y,XMZ,XMM,XMDT
+ N XUH,XUH2,XUU,XUU2
  I '$D(ZTQUEUED) W !!?8,$S(XUNEW:"CREATING A NEW ACCOUNT FOR '"_$P(XUSER(XU1),U,2)_"'",1:"CONVERTING "_$P(XUSER(XU1),U,2)_"'S ACCOUNT OVER"),!!,"One moment please..."
  D BLDFDA
@@ -78,5 +66,4 @@
  ;
 BLDFDA ;Build the FDA
- N X2,X3,X4,X5,X6,X7,XUNODE,XU
  S XFDA="^TMP($J,""XFDA"")",XIEN="^TMP($J,""XIEN"")" K ^TMP($J)
  ;Move piece on nodes from list, Build XU only once
@@ -102,5 +89,4 @@
  ;
 ACODE ;
- N Z
  F Z=0:0 S XUU=$$AC^XUS4(),XUH=$$EN^XUSHSH(XUU) Q:'($D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)))
  Q
@@ -138,5 +124,5 @@
  ;
 LET(DA,XUTEXT) ;Write access letter
- N DIWF,FR,TO,BY,IOP
+ N DIWF,FR,TO,BY
  S DIWF="^DIC(9.2,"_XUTEXT_",1,",DIWF(1)=200,FR=DA,TO=DA,BY="NUMBER",IOP=XUIOP D EN2^DIWF
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSHSH.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSHSH.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUSHSH.m	(revision 636)
@@ -1,3 +1,3 @@
-XUSHSH ;SF-ISC/STAFF - PASSWORD ENCRYPTION ;3/23/89  15:09 ; 
+XUSHSH ;SF-ISC/STAFF - PASSWORD ENCRYPTION ;3/23/89  15:09 ; 4/14/05 1:22pm
  ;;8.0;KERNEL;;Jul 10, 1995
  ;; This is the public domain version of the VA Kernel.
@@ -5,4 +5,13 @@
  ;; Input in X
  ;; Output in X
-A Q
-EN(X) Q X
+ ;; Algorithm for VistA Office EHR encryption (BSL)
+A ; 
+ S X=$$EN(X)
+ Q
+EN(X) ; GENERIC HASHING ENCRYPTION -- USES ASCII ENCODING
+ N %HASH S %HASH=""
+ N %CHAR
+ F %CHAR=1:1:$L(X) D
+ . I %CHAR#2 S %HASH=$A(X,%CHAR)_%HASH
+ . E  S %HASH=%HASH_$A(X,%CHAR)
+ Q %HASH
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08  16:06
- ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004  08:46
+ ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995
  N %ZISOS,%ZISV
  S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL"))
@@ -9,11 +8,9 @@
  I '$D(%ZIS),$D(%IS) M %ZIS=%IS
  S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now
- I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV
- S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1)
  ;
  I $D(ZTQUEUED) D  I '$D(IOP) S POP=1 G EXIT^%ZIS1
  .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
  I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1
- N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
+ N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
  N %ZHFN,%ZISOLD,DTOUT,DUOUT
  ;Save symbols to restore if don't open a device
@@ -34,5 +31,5 @@
  S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q
  S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL
- I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
+ I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
  S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I
  Q
@@ -63,6 +60,5 @@
  ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS.
 CLEAN ;Cleanup env. Called from %ZISC also.
- I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446)
- I $G(IOT)'="HFS" K IO("HFSIO") ;p446
+ K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366)
  S (IOPAR,IOUPAR)=""
  Q
@@ -70,13 +66,9 @@
 RESETVAR ;Reset home IO* variables.
  I '$D(^XUTL("XQ",$J,"IO")) Q
- N %
- F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
- F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
- S POP=0,IO(0)=IO
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO,(IOPAR,IOUPAR)=""
  Q
-SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3
- N %
- F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@%
- F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+SAVEVAR ;Save home IO* variables, called from XUS1
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@%
  Q
 ZISLPC Q  ;No longer called in Kernel v8.
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS1.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08  16:06
- ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005  15:48
+ ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995
 MAIN ;Called from %ZIS with a GO
  I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT
@@ -7,8 +6,9 @@
  I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT
  S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS
- I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
+ I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
  D IOP:$D(IOP),R:'$D(IOP)
  G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP)
  D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT
+ I POP G EXIT:$D(IOP),L1:'$D(IOP)
  I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1
  I POP G EXIT:$D(IOP),L1:'$D(IOP)
@@ -16,18 +16,14 @@
  I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP
  W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") "  ",$P(%Z1,"^")
- D L2^%ZIS2 ;Call
+ D L2^%ZIS2
 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it
+ ;For type[TRM reset $X & $Y
+ I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
  ;
-EXIT ;
- I POP G EX2 ;Did not get the device.
- ;For type[TRM reset $X & $Y
- I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
+EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
  ;Do count of number of times device opened.  Field 51.
- I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D
+ I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D
  . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1
- I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
- I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK
- I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
-EX2 ;
+ I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
  I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active
  G SETVAR:'POP!(%IS["T"),KILVAR
@@ -37,5 +33,5 @@
  S %IS=%IS_%X K IOP W %X D SETQ Q
  ;Get ready to ask user for device
-R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED"
+R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED"
  S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default
  I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1)
@@ -60,5 +56,5 @@
  I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0  ;uppercase lookup
  N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q
-SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W $C(7) S DTOUT=1 Q
+SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W *7 S DTOUT=1 Q
  S:%X="."!(%X="^") DUOUT=1,%X="" Q
 LC S %X=$$UP(%X)
@@ -66,13 +62,10 @@
 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- ;Call/Return % = 1 (yes), 2 (no) -1 (^)
-YN W "? ",$P("Yes// ^No// ",U,%)
-RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W $C(7)
+YN W "? ",$P("YES// ^NO// ",U,%)
+RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W *7
  S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
- I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN
- W:$X>73 ! W $P("  (Yes)^  (No)",U,%)
- Q
-MSG1 I '$D(IOP) W ?20,$C(7),"  [DEVICE DOES NOT EXIST]"
+ I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN
+ W:$X>73 ! W $P("  (YES)^  (NO)",U,%) Q
+MSG1 I '$D(IOP) W ?20,*7,"  [DEVICE DOES NOT EXIST]"
  Q
 SETVAR ;Come here to setup the variables for the selected device
@@ -84,6 +77,5 @@
  S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG
  S:IOF="" IOF="#" ;See that IOF has something
- K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU
- G KIL
+ K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL
  ;
 KILVAR ;Come here to restore the calling variables
@@ -97,6 +89,5 @@
  S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP
 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME
- K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM
- K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
- K %ZISMY,%ZISQUIT,%ZISLOCK
+ K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS2.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08  16:07
- ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002  15:41
+ ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995
 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0
  F  S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0  D  Q:%E
@@ -12,9 +11,6 @@
 L2 ;Entry point from %ZIS1
  I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q
-CHECK ;Get IO check for secondary $I
- K %ZISCPU N %Z2
- S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO.
- S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ;
- S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing
+CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2)
+ S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing 
  I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D  Q
  . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device"
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS3.m	(revision 636)
@@ -1,35 +1,25 @@
-%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08  13:18
- ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
- ;Call with a Go from ^%ZIS2
- I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open
+%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005  13:23
+ ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995
+ I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E)
  I $D(%ZISQUIT) S POP=1 K %ZISQUIT
  S %ZISCHK=1
- ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
- ;See if need to lock.
- K %ZISLOCK
- I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO))
- ;
- I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
- ;
-Q ;%ZIS6 Returns here
- ;See if need to un-lock.
- I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
+ I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
+ G Q:POP
+ G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
+ ; 
+Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
  I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q
- I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
- Q  ;Return to %ZIS1
- ;
+ I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
+ Q
 VTRM ;Virtual terminal type
-TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
- D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE
- I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE
- W:'$D(IOP) !
- I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4
+TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
+ I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE
+ W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
  G Q
-DEVOK N X,Y,X1 ;Not sure this is needed
+DEVOK N X,Y,X1
  S X=IO,X1=%ZTYPE
  D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q
- I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q
- I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q
+ I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q
+ I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q
  Q
  ;
@@ -49,8 +39,7 @@
  S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q
  Q
-SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")"
+SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")"
  Q
-AQUE ;Ask about Queueing
- W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
+AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
  I $D(IO("Q")) W !,"Previously, you have selected queueing."
  W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED"
@@ -58,5 +47,4 @@
  I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q
  I %=1 S IO("Q")=1 C IO K IO(1,IO) Q
- ;I %=2 K IO("Q")
  Q
 ST(%ZISTP) ;
@@ -81,2 +69,3 @@
  S:IOST="" IOST="P-OTHER",IOST(0)=0
  Q
+ 
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4GTM.m	(revision 636)
@@ -1,5 +1,5 @@
-%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08  16:08
- ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;
 OPEN ;From %ZIS3 for TRM
  G OPN2:$D(IO(1,IO))
@@ -13,18 +13,19 @@
  Q
  ;Why no open paraneters???
-OP1 N $ET S $ET="G OPNERR^%ZIS4"
- I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
- O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1
+OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
  Q
 OPNERR ;Open Error
- S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC=""
- Q
+ S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q
  ;
-O ;From %ZIS6 for all types.
+O ;From %ZIS6 for other types.
  D:%IS["L" ZIO
- I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port
+LCKGBL ;Lock Global
+ I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
  I %ZTYPE="CHAN" D TCPIP Q:POP  G OXECUTE^%ZIS6
- S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO)
+ S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
  N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
  S %A=%_$E(":",%A]"")_%A
@@ -39,6 +40,6 @@
  ;
 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
- I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
- O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK
  S IO("ERROR")="" Q
  ;
@@ -53,5 +54,5 @@
  Q
  ;
-TCPIP ;For TCP/IP devices, should use ^%ZISTCP
+TCPIP ;For TCP/IP devices
  N %S
  S %ZISTO=$G(%ZISTO,3)
@@ -66,7 +67,6 @@
  I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
  I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
-R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0
- S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
- G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC
+R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
+ G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC
  S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
@@ -74,19 +74,13 @@
 OK K %ZDA,%ZFN Q
 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
- ;
-SPL2 ;Open for write
- O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
- ;
-SPL3 ;Open for Read
- O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q
+SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP")
+ O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q
- ;
-CLOSE ;Close out the spool
- N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X
- I $L(IO) C IO K IO(1,IO)
- D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
- S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  S %ZCR=$C(13),%Y=""
- S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0
- U %ZFN F  R %X#255:5 Q:$ZEOF  S %2=%X D CL2 Q:%Z1<%
+CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP")
+ S %Z1=+$G(^XTV(8989.3,1,"SPL"))
+ F %=0:0 R %X#255:5 Q:$ZA<0  S %2=%X D CL2 G:%Z1<% SPLEX
+SPLEOF I $ZE'["ENDO" Q  ;Send error up
 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS4ONT.m	(revision 636)
@@ -1,40 +1,36 @@
-%ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (Cache) ;1/24/08  16:08
- ;;8.0;KERNEL;**34,59,69,191,278,293,440**;Jul 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
-OPEN ;Called for TRM devices
- G OPN2:$D(IO(1,IO))
+%ZIS4 ;SFISC/RWF,AC - DEVICE HANDLER SPOOL SPECIFIC CODE (OpenM/WNT) ;11/03/2003  17:32
+ ;;8.0;KERNEL;**34,59,69,191,278,293**;Jul 10, 1995
+ ;
+OPEN G OPN2:$D(IO(1,IO))
  S POP=0 D OP1 G NOPEN:'$D(IO(1,IO))
-OPN2 ;
- I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
+OPN2 I $D(%ZISHP),'$D(IOP) W !,$C(7)_" Routing to device "_$P(^%ZIS(1,%E,0),"^",1)_$S($D(^(1)):" "_$P(^(1),"^",1)_" ",1:"")
  Q
-NOPEN ;
- I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
+NOPEN I %IS'["D",$D(%ZISHP)!(%ZISHG]"") S POP=1 Q
  I '$D(IOP) W $C(7)_"  [BUSY]" W "  ...  RETRY" S %=2,U="^" D YN^%ZIS1 G OPEN:%=1
+ K:%E'=%H ^XUTL("ZISPARAM",IO)
  S POP=1 Q
  Q
-OP1 N $ET S $ET="G OPNERR^%ZIS4"
- I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
- O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1
+OP1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
  Q
-OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC=""
- Q
+OPNERR S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$ZE,$EC="" Q
  ;
-O ;Gets called for all devices
- N X,%A1
- D:%ZIS["L" ZIO
+O N X D:%IS["L" ZIO
  I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer port
-OPAR I $D(IOP),%ZTYPE="HFS",$D(%ZIS("HFSIO")),$D(%ZIS("IOPAR")),%ZIS("HFSIO")]"" S IO=%ZIS("HFSIO"),%ZISOPAR=%ZIS("IOPAR")
- S %A=$S($L(%ZISOPAR):%ZISOPAR,%ZTYPE'["TRM":"",$E(%ZISIOST,1)="C":"("_+%Z91_":""C"")",$E(%ZISIOST,1,2)="PK":"("_+%Z91_":""P"")",1:+%Z91)
+OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
+ S %A=$S(%ZISOPAR]"":%ZISOPAR,%ZTYPE'["TRM":"",%ZISIOST?1"C".E:"("_+%Z91_":""C"")",%ZISIOST?1"PK".E:"("_+%Z91_":""P"")",1:+%Z91)
  S %A=%A_$S(%A["):":"",%ZTYPE["OTH"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO),%A=""""_IO_""""_$E(":",%A]"")_%A
  D O1 I POP W:'$D(IOP) !,?5,$C(7)_"[Device is BUSY]" Q
  ;I %ZTYPE="HFS" U IO S X=IO,IO=IO_";"_$P($ZIO,";",2),IO(1,IO)="" K IO(1,X)
  U IO S $X=0,$Y=0
- I $L(%ZISUPAR) S %A1=""""_IO_""":"_%ZISUPAR U @%A1
+ I %ZISUPAR]"" S %A1=""""_IO_""":"_%ZISUPAR U @%A1
  ;U:%IS'[0 IO(0)
  G OXECUTE^%ZIS6
  ;
-O1 N $ET S $ET="G OPNERR^%ZIS4"
- I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
+O1 N X S X="OPNERR^%ZIS4",@^%ZOSF("TRAP")
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
  O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
+ L:$D(%ZISLOCK) -@%ZISLOCK
  S IO("ERROR")=""
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZIS6.m	(revision 636)
@@ -1,10 +1,7 @@
-%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08  16:09
- ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000  08:14
+ ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995
  ;Expect that IO is current device
-OXECUTE ;Open Execute
- I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
-ANSBAK ;Answer Back
- I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
+OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
+ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
  I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT
  G QUIT:'$D(IO("P"))
@@ -63,17 +60,13 @@
 HG ;
  Q
-SPL ;Spool type
- N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T"
+SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type
  G Q
 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type
  G Q
-SDP ;Sequential disk processor type
- D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type
  G Q
-HFS ;Host File Server type
- D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type
  G Q
-RES ;Resources
- G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q
+RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q  ;Resources
  G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP
  D:%ZISB RES1 G Q
@@ -84,18 +77,12 @@
 IMPC ;Imaging Work Station
 BAR ;Bar Code
-OTH ;Other Device type
- D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type
  G Q
  ;
-ASKPAR ;Ask Parameters
- G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
+ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
  I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q
  Q:POP  G SETPAR^%ZIS3
+AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
+ S:%=1 %ZISMTR=1 Q
+MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q
  ;
-AMTREW ;Mag Tape Rewind
- I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
- S:%=1 %ZISMTR=1
- Q
-MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25
- Q
- ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISC.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;1/24/08  16:09
- ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;01/14/2002  09:06
+ ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3
 C0 ;
  N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV
@@ -42,7 +41,9 @@
  . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0)
  . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device
- ;Unlock global used to control access.
- S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS)
  ;
+ ;
+ I $D(IOT),IOT="CHAN",$D(IOS) D
+ .S %=$G(^%ZIS(1,+IOS,"GBL"))
+ .I %]"" L @("-^"_%) ;unlock global used to control access to network channels.
  I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISEDIT.m	(revision 636)
@@ -1,49 +1,23 @@
-ZISEDIT ;ISF/AC - DEVICE EDIT ;01/17/2008
- ;;8.0;KERNEL;**440**;Jul 10, 1995;Build 13
+ZISEDIT ;SFISC/AC - DEVICE EDIT ;11/9/92  17:00
+ ;;8.0;KERNEL;;Jul 10, 1995
  ;
-TRM ;TRM or VTRM
- D EDIT("TRM",,"Select Terminal/Printer Device: ")
+MT S ZISTYPE="MT",DIC("A")="Select Magtape Device: " D EDIT K ZISTYPE
  Q
  ;
-LPD ;LPD fields of a TRM device
- D EDIT("LPD","TRM","Select LPD (Terminal/Printer) Device: ")
+SDP S ZISTYPE="SDP",DIC("A")="Select SDP Device: " D EDIT K ZISTYPE
  Q
  ;
-MT ;Mag Tape
- D EDIT("MT",,"Select Magtape Device: ")
+SPL S ZISTYPE="SPL",DIC("A")="Select Spool Device: " D EDIT K ZISTYPE
  Q
  ;
-SDP ;
- D EDIT("SDP",,"Select SDP Device: ")
+HFS S ZISTYPE="HFS",DIC("A")="Select Host File Device: " D EDIT K ZISTYPE
  Q
  ;
-SPL ;Spool
- D EDIT("SPL",,"Select Spool Device: ")
+CHAN S ZISTYPE="CHAN",DIC("A")="Select Network Channel: " D EDIT K ZISTYPE
  Q
- ;
-HFS ;Host file
- D EDIT("HFS",,"Select Host File Device: ")
- Q
- ;
-CHAN ;Network
- D EDIT("CHAN",,"Select Network Channel: ")
- Q
- ;
-RES ;Resource
- D EDIT("RES",,"Select Resource Device: ")
- Q
- ;
-EDIT(ZISTYPE,ZISSCR,DICA) ;
- N Y,DA,DIC,DIE,DR,DDSFILE
-ED2 S DIC("A")=DICA,ZISSCR=$G(ZISSCR,ZISTYPE)
- S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))["_""""_ZISSCR_"""" D ^DIC
- Q:Y'>0
- S DA=+Y
- I $P(Y,"^",3) D
- . N DIE,DR
- . S DIE=DIC,DR="2///"_ZISTYPE_$S(ZISTYPE["TRM":"",1:";1.95///N")
- . D ^DIE
- . Q
+ ;;7.1P0;Kernel;;
+EDIT S DIC=3.5,DIC(0)="AEMQZL",DIC("S")="I $G(^(""TYPE""))="_""""_ZISTYPE_"""" D ^DIC
+ I Y'>0 K DIC Q
+ S DA=+Y I $P(Y,"^",3) S DIE=DIC,DR="2///"_ZISTYPE D ^DIE K DIE,DR
  S DR="[XUDEVICE "_ZISTYPE_"]",DDSFILE=3.5 D ^DDS
- G ED2
- Q
+ K DA,DR,DDSFILE Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISHONT.m	(revision 636)
@@ -1,5 +1,5 @@
-%ZISH ;IHS/PR,SFISC/AC - Host File Control for Cache for VMS/NT/UNIX ;1/24/08  16:11
- ;;8.0;KERNEL;**34,65,84,104,191,306,385,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZISH ;IHS\PR,SFISC/AC - Host File Control for OpenM/Cache for NT/VMS ;12/13/2005
+ ;;8.0;KERNEL;**34,65,84,104,191,306,385**;JUL 10, 1995;Build 3
+ ;
  ; **MODIFIED VERSION FOR CACHE/VMS -- 9/7/01**
  ;
@@ -43,61 +43,26 @@
  Q 0
  ;
-DEL(%ZX1,%ZX2) ;ef,SR. Del files, return 1 if deleted all requested.
+DEL(%ZX1,%ZX2) ;ef,SR. Del fl(s)
  ;S Y=$$DEL^%ZISH("dir path",$NA(array))
- ; will invoke an OS command to delete file(s)
- ; UNIX: rm -f filespec[ ...]
- ; VMS: del filespec[,...]
- N %ZARG,%ZXDEL,%ZOS,%ZDELIM,%ZCOMND,%ZLIST
- S %ZARG="",%ZXDEL=1
- S %ZX1=$$DEFDIR($G(%ZX1))
- S %ZOS=$$OS^%ZOSV
- S %ZDELIM=$S(%ZOS="UNIX":" ",1:",")
- S %ZCOMND=$S(%ZOS="UNIX":"rm -f ",1:"del ")
- D
+ N %,%ZX,%ZXDEL,%ZISH,%ZOS
+ S %ZX1=$$DEFDIR($G(%ZX1)),%ZOS=$$OS^%ZOSV,%ZXDEL=1,%ZISH=""
+ F  S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
  . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
- . N %,%ZI,%ZISH,%ZX,%ZFOUND S %ZISH=""
- . F %ZI=1:1 S %ZISH=$O(@%ZX2@(%ZISH)) Q:%ZISH=""  D
- . . N $ETRAP,$ESTACK S $ETRAP="D DELERR^%ZISH"
- . . I %ZISH["*" S %ZXDEL=0 Q  ; Wild card not allowed.
- . . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH) ; prepend directory path
- . . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*"
- . . S %ZFOUND=$ZSEARCH(%ZX)]""  ; File exists
- . . S:%ZFOUND %ZARG=$S(%ZARG="":%ZX,1:%ZARG_%ZDELIM_%ZX) ; join files
- . . I $L(%ZARG)>2000 S %=$ZF(-1,%ZCOMND_%ZARG),%ZARG="" H 1 ; delete files at a time
- . ;
- . I $L(%ZARG) S %=$ZF(-1,%ZCOMND_%ZARG) ; delete remaining files
- ;
- I %ZXDEL S %ZXDEL='$$LIST(%ZX1,%ZX2,"%ZLIST")
+ . I %ZISH["*" S %ZXDEL=0 Q  ; Wild card not allowed.
+ . S %ZX=$S(%ZISH[%ZX1:%ZISH,1:%ZX1_%ZISH)
+ . I %ZOS="VMS",%ZX'[";" S %ZX=%ZX_";*"
+ . Q:$ZSEARCH(%ZX)']""  ; File doesn't exist
+ . S %=$ZF(-1,$S(%ZOS="UNIX":"rm ",1:"del ")_%ZX)
+ . I $ZSEARCH(%ZX)]"" S %ZXDEL=0 ; Delete was not successful.
  Q %ZXDEL
  ;
 DELERR ;Trap any $ETRAP error, unwind and return.
  S $ETRAP="D UNWIND^%ZTER"
- S %ZXDEL=0,%ZARG=""
+ S %ZXDEL=0
  D UNWIND^%ZTER
  Q
  ;
-DEL1(%ZX3) ;ef,SR. Delete one file
- N %ZI1,%ZI2
- D SPLIT(%ZX3,.%ZI1,.%ZI2) S %ZI2(%ZI2)=""
- Q $$DEL(%ZI1,$NA(%ZI2))
- ;
-SPLIT(%I,%O1,%O2) ;Split to path,file
- N %ZOS,%D,D S %ZOS=$$OS^%ZOSV
- I %ZOS["VMS" D  Q
- . S D=$S(%I["]":"]",1:":")
- . S %O1=$P(%I,D,1)_D,%O2=$P(%I,D,2)
- . Q
- S %D=$S(%ZOS="UNIX":"/",%ZOS="NT":"\",1:""),%O1="",%O2="" Q:%D=""
- S D=$L(%I,%D),%O1=$P(%I,%D,1,D-1),%O2=$P(%I,%D,D)
- Q
- ;
-FEXIST(%PATH,%FL) ;Check if files exsist.
- ;S Y=$$DTEST("/usr/var",$NA(array))
- N %ZISH,%ZISHY
- S %ZISH=$$LIST(%PATH,%FL,"%ZISHY")
- Q %ZISH
- ;
 LIST(%ZX1,%ZX2,%ZX3) ;ef,SR. Create a local array holding file names
- ;S Y=$$LIST^%ZISH("\dir\",$NA(array),$NA(return array)) Return 1 if found anything
+ ;S Y=$$LIST^ZOSHDOS("\dir\",$NA(array),$NA(return array)) Return 1 if found anything
  ;
  N %ZISH,%ZISHN,%ZX,%ZISHY,%ZY,%ZOS
@@ -110,5 +75,5 @@
  . ;NT, display case, ignore for lookup
  . S %ZX=%ZX1_%ZISH
- . F %ZISHN=0:1 D  Q:(%ZX="")
+ . F %ZISHN=0:1 D  Q:(%ZX="") 
  . . S %ZX=$ZSEARCH($S(%ZISHN:"",1:%ZX))
  . . ;Q:(%ZX="")!($$UP^XLFSTR(%ZX)'[%ZISHY)!(%ZX?.E1.2".")
@@ -161,5 +126,5 @@
  N %ZOS,P1,P2 S %ZOS=$$OS^%ZOSV,DF=$G(DF)
  Q:DF="." "" ;Special way to get current dir.
- S:DF="" DF=$G(^XTV(8989.3,1,"DEV")),DF=$P(DF,"^",$S($$PRI^%ZOSV<2:1,1:2))
+ S:DF="" DF=$G(^XTV(8989.3,1,"DEV"))
  Q:DF="" ""
  ;Check syntax, VMS needs disk:[dir] or logical:
@@ -171,10 +136,10 @@
  . S DF=P1_P2 S:DF'[":" DF=DF_":"
  . Q
- ;Check syntax, Unix needs /mnt/fl, ./fl, ~/fl $HOME/fl
+ ;Check syntax, Unix needs /mnt/fl, ./fl
  I %ZOS="UNIX" D
  . S DF=$TR(DF,"\","/")
  . S:$E(DF,$L(DF))'="/" DF=DF_"/"
  . Q
- ;Check syntax, NT needs c:\dir\
+ ;Check syntax, NT needs c:\dir\ 
  I %ZOS="NT" D
  . N P1,P2
@@ -227,5 +192,5 @@
  ;
 FTG(%ZX1,%ZX2,%ZX3,%ZX4,%ZX5) ;ef,SR. Unload contents of host file into global
- ;p1=hostf file directory
+ ;p1=hostf file directory 
  ;p2=host file name
  ;p3= $NAME REFERENCE INCLUDING STARTING SUBSCRIPT
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZISS1.m	(revision 636)
@@ -1,15 +1,9 @@
-%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;1/24/08  16:10
- ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
-VALID ;
- N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- D L
+%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;11/05/97  08:40
+ ;;8.0;KERNEL;**69**;JUL 10, 1995
+VALID D L K %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN Q
+ ;
+SET2 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
  Q
- ;
-SET2 ;
- S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
- Q
-INDCK ;
- S %ZISY=""
+INDCK S %ZISY=""
  I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
  I %ZISXX]"" S @("%ZISY="_%ZISXX)
@@ -18,30 +12,25 @@
  E  S @("IO"_$E(%ZISFN,1,6))=%ZISY
  Q:'$D(%ZIS)#2  Q:%ZIS'["I"  Q:'$D(%ZISZ(%ZISFN,1))
- ;
-SRAY ;
- S %=%ZISY,%ZISY=$A($E(%ZISY,1))
+SRAY S %=%ZISY,%ZISY=$A($E(%ZISY,1))
  F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1))
  S IOIS(%ZISY)=%ZISFN
  Q
 CHECK ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- S %ZISXX=X D L S X=%ZISYY
+ S %ZISXX=X D L S X=%ZISYY K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
  Q
 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
  S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X)
- D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY)
+ D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
  Q
 FORM ;Entry point called from input transforms of fields in DEV/TT files.
  Q:$L(X,"_")'>1
- N %ZISSI,%ZISSY ;p440
  ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X
  S %ZISSY=""
  F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_")
- S X=%ZISSY
+ S X=%ZISSY K %ZISSI,%ZISSY
  Q
  ;
 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q
- S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
+ S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
  ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q
  S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX
@@ -52,13 +41,8 @@
  I ZISCH="*" D STAR Q
  I ZISCH="(" D PAREN Q
- S %ZISYY=%ZISYY_ZISCH
+ S %ZISYY=%ZISYY_ZISCH Q
+L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
  Q
-L2 ;Find $C(x)_$C(y) and merge
- N I ;p440
- F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
- Q
-L3 ;
- N I
- F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
+L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
  Q
 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q
@@ -67,11 +51,9 @@
 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q
  Q
-DOLR ;Looking for $C.
+DOLR ;LOOKING FOR $C.
  I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q
- I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q
- S %ZISYY=%ZISYY_"$" ;p440
+ I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN
  Q
-PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1
- Q
+PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 Q
 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP))
  Q
@@ -79,6 +61,5 @@
  I ZISCH="$" D DOLR Q
  I ZISCH="(" D PAREN Q
- S %ZISYY=%ZISYY_ZISCH
- Q
+ S %ZISYY=%ZISYY_ZISCH Q
  ;
 S2 ;MERGE $C
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSFONT.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSFONT.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSFONT.m	(revision 636)
@@ -1,16 +1,11 @@
-ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF for Cache for NT/VMS ;10/19/06  14:01
- ;;8.0;KERNEL;**34,104,365**;JUL 10, 1995;Build 5
- ;For Cache versions 3.2, 4 and 5
+ZOSFONT ;SFISC/AC - SETS UP ^%ZOSF FOR Open M for NT ;09/29/98  08:26
+ ;;8.0;KERNEL;**34,104**;JUL 03, 1995
  S %Y=1 K ^%ZOSF("MASTER"),^%ZOSF("SIGNOFF")
- N ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I)
+ K ZO F I="MGR","PROD","VOL" S:$D(^%ZOSF(I)) ZO(I)=^%ZOSF(I)
  F I=1:2 S Z=$P($T(Z+I),";;",2) Q:Z=""  S X=$P($T(Z+1+I),";;",2,99) S ^%ZOSF(Z)=$S($D(ZO(Z)):ZO(Z),1:X)
- ;
-MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:0[Y S ^%ZOSF("MGR")=X
-PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:0[Y S ^%ZOSF("PROD")=Y
-VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.22U ^%ZOSF("VOL")=X I X'?1.22U W "MUST BE 1-22 uppercase characters." G VOL
- ;
+MGR W !,"NAME OF MANAGER'S NAMESPACE: "_^%ZOSF("MGR")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G MGR:Y="" S ^%ZOSF("MGR")=X
+PROD W !,"PRODUCTION (SIGN-ON) NAMESPACE: "_^%ZOSF("PROD")_"// " R X:$S($G(DTIME):DTIME,1:9999) I X]"" X ^("UCICHECK") G PROD:Y="" S ^%ZOSF("PROD")=Y
+VOL W !,"NAME OF THIS CONFIGURATION: "_^%ZOSF("VOL")_"//" R X:$S($G(DTIME):DTIME,1:9999) I X]"" S:X?1.5U ^%ZOSF("VOL")=X I X'?1.5U W "MUST BE 1-5 uppercase characters." G VOL
 OS S $P(^%ZOSF("OS"),"^",1)="OpenM-NT" S:'$P(^%ZOSF("OS"),"^",2) $P(^%ZOSF("OS"),"^",2)=18
- ;For Cache 5.1 and above
- I $$VERSION^ZOSVONT>5 S ^%ZOSF("GSEL")="K ^CacheTempJ($J),^UTILITY($J) D ^%SYS.GSET M ^UTILITY($J)=CacheTempJ($J)"
  W !!,"ALL SET UP",!! Q
 Z ;;
@@ -22,5 +17,5 @@
  ;;U $I:("":"+B")
  ;;DEL
- ;;X "ZR  ZS @X"
+ ;;X "ZR  ZS @X" K ^UTILITY("ROU",X)
  ;;EOFF
  ;;U $I:("":"+S")
@@ -35,6 +30,4 @@
  ;;GD
  ;;D ^%GD
- ;;GSEL;Select Globals
- ;;K ^UTILITY($J) D ^%GSET
  ;;JOBPARAM
  ;;D JOBPAR^%ZOSV
@@ -42,5 +35,5 @@
  ;;U IO:("":"+S+I-T":$C(13,27))
  ;;LOAD
- ;;N %,%N S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
+ ;;S %N=0 X "ZL @X F XCNP=XCNP+1:1 S %N=%N+1,%=$T(+%N) Q:$L(%)=0  S @(DIF_XCNP_"",0)"")=%"
  ;;LPC
  ;;S Y=$ZC(X)
@@ -72,5 +65,5 @@
  ;;D @($S(X>7:"NORMAL",X>3:"NORMAL",1:"LOW")_"^%PRIO") ;Don't do HIGH
  ;;PROGMODE
- ;;S Y=$ZJOB#2
+ ;;S Y=$ZJ#2
  ;;PROD
  ;;VAH
@@ -78,17 +71,15 @@
  ;;D ^%RD
  ;;RESJOB
- ;;N OLD S OLD=$ZNSPACE ZNSPACE "%SYS" D ^RESJOB ZNSPACE OLD Q
+ ;;Q:'$D(DUZ)  Q:'$D(^XUSEC("XUMGR",+DUZ))  N XQZ S XQZ="^RESJOB[MGR]" D DO^%XUCI
  ;;RM
- ;;I $G(IOT)["TRM" U $I:X
+ ;;U $I:X
  ;;RSEL;;ROUTINE SELECT
  ;;K ^UTILITY($J) D KERNEL^%RSET K %ST ;Special entry point for VA
  ;;RSUM
- ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
- ;;RSUM1
- ;;N %,%1,%3 ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*(%2+%)+Y
+ ;;ZL @X S Y=0 F %=1,3:1 S %1=$T(+%),%3=$F(%1," ") Q:'%3  S %3=$S($E(%1,%3)'=";":$L(%1),$E(%1,%3+1)=";":$L(%1),1:%3-2) F %2=1:1:%3 S Y=$A(%1,%2)*%2+Y
  ;;SS
  ;;D ^%SS
  ;;SAVE
- ;;N XCS S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X"
+ ;;S XCS="F XCM=1:1 S XCN=$O(@(DIE_XCN_"")"")) Q:+XCN'=XCN  S %=^(XCN,0) Q:$E(%,1)=""$""  I $E(%,1)'="";"" ZI %" X "ZR  X XCS ZS @X" S ^UTILITY("ROU",X)="" K XCS
  ;;SIZE
  ;;S Y=0 F I=1:1 S %=$T(+I) Q:%=""  S Y=Y+$L(%)+2
@@ -97,5 +88,5 @@
  ;;TMK;;MAGTAPE MARK
  ;;S Y=$ZA\4#2
- ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP"); User $ETRAP
+ ;;TRAP;;S X="^%ET",@^%ZOSF("TRAP") TO SET ERROR TRAP
  ;;$ZT=X
  ;;TRMOFF
@@ -103,5 +94,5 @@
  ;;TRMON
  ;;U $I:("":"+I+T")
- ;;TRMRD;;old Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
+ ;;TRMRD
  ;;S Y=$A($ZB),Y=$S(Y<32:Y,Y=127:Y,1:0)
  ;;TYPE-AHEAD
@@ -117,4 +108,4 @@
  ;;VOL;;VOLUME SET NAME
  ;;ROU
- ;;ZD;;$H to external
+ ;;ZD
  ;;S Y=$ZD(X)
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSV2GTM.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSV2GTM.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSV2GTM.m	(revision 636)
@@ -1,4 +1,21 @@
 %ZOSV2 ;ISF/RWF - More GT.M support routines ;10/18/06  14:29
- ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 
  Q
  ;SAVE: DIE open array reference.
@@ -25,6 +42,6 @@
  S $ETRAP="S $ECODE="""" Q"
  S %I=$I,%DIR=$$RTNDIR^%ZOSV,RN=$TR(RN,"%","_")
- I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "DEL "_%DIR_X_".m;*"
- I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "DEL "_%DIR_X_".obj;*"
+ I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "rm -f "_%DIR_X_".m"
+ I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "rm -f "_%DIR_X_".obj"
  I $L($ZSEARCH(%DIR_RN_".o",244)) ZSYSTEM "rm -f "_%DIR_X_".o"
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVONT.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZOSV ;SFISC/AC - $View commands for Open M for NT.  ;03/03/2008
- ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425,440**;Jul 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZOSV ;SFISC/AC - $View commands for Open M for NT.  ;4/26/07  09:39
+ ;;8.0;KERNEL;**34,94,107,118,136,215,293,284,385,425**;Jul 10, 1995;Build 18
 ACTJ() ;# Active jobs
  N %,V,Y S V=$$VERSION()
@@ -14,11 +13,11 @@
  ;maxpid: from %SS
  I V<5 D  Q AVJ
- . N PORT,T,X,MAXPID,LMFLIM
- . S $ET="",MAXPID=$V($ZU(40,2,118),-2,4)
- . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S LMFLIM=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info
+ . N port,t,x,maxpid,lmflim
+ . S $ET="",maxpid=$V($ZU(40,2,118),-2,4)
+ . X "S ZOSV=$ZU(5),%=$ZU(5,""%SYS"") S lmflim=$$inquire^LMFCLI,%=$ZU(5,ZOSV)" ;Get the license info
  . ;Add together the enterprise and division licenses avaliable
- . S X=$P(LMFLIM,";",2)+$P($P(LMFLIM,"|",2),";",2)
- . S T=+LMFLIM+$P(LMFLIM,"|",2) ;Check the license total
- . S AVJ=$S(T<MAXPID:X,1:MAXPID-$$ACTJ) ;Return the smaller of license or pid
+ . S x=$P(lmflim,";",2)+$P($P(lmflim,"|",2),";",2)
+ . S t=+lmflim+$P(lmflim,"|",2) ;Check the license total
+ . S AVJ=$S(t<maxpid:x,1:maxpid-$$ACTJ) ;Return the smaller of license or pid
  ;To get available jobs from Cache 5.0 up
  I V'<5 D  Q AVJ
@@ -39,5 +38,5 @@
  ;
 GETPEER() ;Get the PEER tcp/ip address
- N PEER,NL,$ET S NL="",PEER="",$ET="S $EC=NL Q NL"
+ N PEER,NL,$ET S NL="",$ET="S $EC=NL Q NL",PEER=""
  I $$OS="VMS" S PEER=$ZF("TRNLNM","VISTA$IP")
  I '$L(PEER) S PEER=$ZU(111,0) S:$L(PEER) PEER=$A(PEER,1)_"."_$A(PEER,2)_"."_$A(PEER,3)_"."_$A(PEER,4)
@@ -45,17 +44,16 @@
  ;
 SHARELIC(TYPE) ;See if can share a C/S license
- ;Per Sandy Waal 10/18/2003: With Cache 5.0, your telnet and IP connections are now handled properly.
- ;N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION()
- ;I %V'<5 Q
  ;Type is 1 for C/S and 0 for Telnet
- ;I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q
- ;I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE
- ;S $EC=""
+ N %,%N,%2,UID,%V,$ET S $ET="S $EC="""" Q",%V=$$VERSION()
+ I %V<3.1 X:TYPE "S %N=$ZU(5),%2=$ZU(5,""%SYS""),%2=$$GetLic^LMFCLI,%N=$ZU(5,%N)" Q
+ I %V<5 S:TYPE %=$$GetCSLic^%LICENSE S:'TYPE %=$$ShareLic^%LICENSE
+ ;Per Sandy Waal 10/18/2003: With Cache' 5.0, your telnet and IP connections are now handled properly.
+ I %V'<5 S %V=%V
+ S $EC=""
  Q
- ;
 JOBPAR ;See if X points to a valid Job. Return its UCI.
- N NL,$ET S Y="",NL="",$ET="S $EC=NL Q"
- I $D(^$JOB(X)) S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL")
- Q
+ N ZJ S Y="",$ZT="JOBX"
+ Q:'$D(^$JOB(X))  S Y=$V(-1,X),Y=$P(Y,"^",14)_","_^%ZOSF("VOL")
+JOBX Q
  ;
 NOLOG ;4096 is switch 12 - sign on inhibited.
@@ -63,5 +61,5 @@
  ;
 PROGMODE() ;Check if in PROG mode
- Q $ZJOB#2
+ Q $ZJ#2
  ;
 PRGMODE ;
@@ -72,10 +70,9 @@
  D UCI S XUCI=Y,XQZ="PRGM^ZUA[MGR]",XUSLNT=1 D DO^%XUCI D ^%PMODE U $I:(:"+B+C+R") S $ZT="" Q
  Q
-LGR() ;Last Global ref.
- N $ET,NL S NL="",$ET="S $EC=NL Q NL"
- Q $ZR
+LGR() S $ZT="LGRX^%ZOSV"
+ Q $ZR ;Last Global ref.
+LGRX Q ""
  ;
-EC() ;Error code
- Q $ZE
+EC() Q $ZE ;Error code
  ;
 DOLRO ;SAVE ENTIRE SYMBOL TABLE IN LOCATION SPECIFIED BY X
@@ -95,12 +92,11 @@
  Q
  ;
-PARSIZ ;Old and not used.
+PARSIZ ;
  S X=3
  Q
  ;
-DEVOPN ;List of Devices opened, Not used
+DEVOPN ;List of Devices opened
  ;Returns variable Y. Y=Devices owned separated by a comma
  Q
- ;
 DEVOK ;
  S Y=0,X1=$G(X1) Q:X=2  Q:(X1="HFS")!(X1="SPL")!(X1="MT")!(X1="CHAN")  ;Quit w/ OK for HFS, Spool, MT, TCP/IP
@@ -122,5 +118,5 @@
  ;
 OS() ;Return the OS NT, VMS, Unix
- Q $S($ZV["VMS":"VMS",$ZV["UNIX":"UNIX",$ZV["Linux":"UNIX",$ZV["Windows":"NT",$ZV["NT":"NT",1:"UNK")
+ Q $S($ZV["VMS":"VMS",$ZV["Windows":"NT",$ZV["NT":"NT",$ZV["UNIX":"UNIX",1:"UNK")
  ;
 SETNM(X) ;Set name, Fall into SETENV
@@ -131,10 +127,8 @@
  ;
 SID() ;System ID Ver 1
- N %1,%2,%3,%4,%5,T S T="~"
+ N %1,%2,%3,T S T="~"
  S %1=$ZU(5) ;namespace
  S %2=$ZU(12,"") ;directory
  I '$L(%2),$$VERSION'<5.2 S %2=$$defdir^%SYS.GLO(%1) ;remote directory
- S %3=$G(^XTV(8989.3,1,"SID")),%4=$P(%3,"^",4),%5=$P(%3,"^",5)
- I $L(%4),$L(%5),%2[%4 S %2=$P(%2,%4)_%5_$P(%2,%4,2,9)
  S %3=%1_T_%2 ;namespace~directory
  Q "1~"_%3
@@ -142,7 +136,8 @@
 PRI() ;Check if a mixed OS enviroment.
  ;Default return 1 unless we are on the secondary OS.
- ;Only Cache on a VMS(1)/Linux or NT(2) mix is supported now.
+ ;Only Cache on a VMS(1)/Linux(2) mix is supported now.
  N % S %=1
  I $P(^XTV(8989.3,1,0),"^",5),$$OS'="VMS" S %=2
+ ;I $P(^XTV(8989.3,1,0),"^",5),$$OS["NT" S %=2
  Q %
  ;
@@ -162,5 +157,5 @@
  Q 1
  ;
-T0 ; start RT clock, obsolete
+T0 ; start RT clock
  ;S XRT0=$H
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTLOAD4.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTLOAD4.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTLOAD4.m	(revision 636)
@@ -1,12 +1,11 @@
-%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;1/24/08  16:15
- ;;8.0;KERNEL;**440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
- ;Call with ZTSK, [ZTCPU]; Return ZTSK()
+%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91  11:55 ;
+ ;;8.0;KERNEL;;JUL 10, 1995
+ ;;7.0;
+ ;
 INPUT ;check input parameters for error conditions
- N %,$ES,$ET,%ZTVOL,ZTREC,ZTD,ZT1,ZT2,ZT3
  I $D(ZTSK)[0 S ZTSK=""
- I $D(ZTSK)>1 S %=ZTSK K ZTSK S ZTSK=%
+ I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD
  I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT
- S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES  S $EC="""" G QUIT^%ZTLOAD4"
+ S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP")
  S %ZTVOL=^%ZOSF("VOL")
  I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
@@ -15,19 +14,18 @@
  ;
 HERE ;lookup task's status on current volume set
- L +^%ZTSK(ZTSK):1
- I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
- S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04))
- S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H
+ L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
+ S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  ;
- S ZT1="" F  S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="IO",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="JOB",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="LINK",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0
  ;
 QUIT ;cleanup and quit
- L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
+ L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
  I ZTSK(0)]"" K ZTSK("E") Q
  I ZTSK("E")'="U" Q
@@ -36,5 +34,4 @@
  ;
 THERE ;rest of code looks up task's status on some other volume set
- N %ZTCPU,%ZTM,X,Y
  ;
 FILES ;find TaskMan files on the volume set to be searched
@@ -48,13 +45,13 @@
 SEARCH ;find out if task is queued on that volume set
  I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
- S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04))
- S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6)
+ S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  ;
- S ZT1="" F  S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="IO",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="JOB",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="LINK",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0 G QUIT
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTMGRSET.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTMGRSET.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZTMGRSET.m	(revision 636)
@@ -1,4 +1,12 @@
-ZTMGRSET ;SF/RWF,PUG/TOAD - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;02/22/2006
+ZTMGRSET ;SF/RWF,PUG/TOAD - SET UP THE MGR ACCOUNT FOR THE SYSTEM ;6:53 PM  24 Jan 2008
  ;;8.0;KERNEL;**34,36,69,94,121,127,136,191,275,355**;JUL 10, 1995;Build 9
+ ;
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
  ;
  N %D,%S,I,OSMAX,U,X,X1,X2,Y,Z1,Z2,ZTOS,ZTMODE,SCR
@@ -165,5 +173,5 @@
  ;
 R() ; routine directory for GT.M
- Q d(1) ;
+ ;Q d(1) ;WVEHR/SO Commented out
  I ZTOS=7 Q $P($ZRO,",")
  I ZTOS=8 Q $P($S($ZRO["(":$P($P($ZRO,"(",2),")"),1:$ZRO)," ")_"/"
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;1/24/08  16:06
- ;;8.0;KERNEL;**18,23,69,112,199,191,275,363,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS ;SFISC/AC,RWF -- DEVICE HANDLER ;10/14/2004  08:46
+ ;;8.0;KERNEL;**18,23,69,112,199,191,275,363**;JUL 10, 1995
  N %ZISOS,%ZISV
  S U="^",%ZISOS=$G(^%ZOSF("OS")),%ZISV=$G(^%ZOSF("VOL"))
@@ -9,11 +8,9 @@
  I '$D(%ZIS),$D(%IS) M %ZIS=%IS
  S:'($D(%ZIS)#2) %ZIS="M" M %IS=%ZIS ;update %IS for now
- I '$D(^XUTL("XQ",$J,"MIXED OS")) S ^XUTL("XQ",$J,"MIXED OS")=$$PRI^%ZOSV
- S %ZIS("PRI")=$G(^XUTL("XQ",$J,"MIXED OS"),1)
  ;
  I $D(ZTQUEUED) D  I '$D(IOP) S POP=1 G EXIT^%ZIS1
  .I $D(ZTIO)#2,ZTIO="" S:%IS'[0 %IS=%IS_"0",%ZIS=%ZIS_"0"
  I '$D(ZTQUEUED),%IS["T",$P($G(IOP),";")="Q" S POP=1 G EXIT^%ZIS1
- N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z2,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
+ N %,%A,%E,%H,%I,%X,%XX,%Y,%Z,%Z1,%Z9,%Z90,%Z91,%Z95,%ZISB,%ZTIME,%ZTYPE
  N %ZHFN,%ZISOLD,DTOUT,DUOUT
  ;Save symbols to restore if don't open a device
@@ -34,5 +31,5 @@
  S %=$$LINEPORT^%ZISUTL I % S (%E,%H)=% Q
  S %ZISVT=$I D VTLKUP I '%E S %ZISVT=$I D VIRTUAL
- I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE ("_$I_") DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
+ I %ZISVT=""!(%E'>0) I %IS'[0 O IO(0)::0 I $T U IO(0) W !,"HOME DEVICE DOES NOT EXIST IN THE DEVICE FILE",!,"PLEASE CONTACT YOUR SYSTEM MANAGER!",*7
  S %H=%E S:'%H&(%IS'[0) POP=1 S:(%H>0)&('$D(IO("HOME"))) IO("HOME")=%H_"^"_$I
  Q
@@ -63,6 +60,5 @@
  ;IO("Q") is checked by many routines after a call to ^%ZISC, so only clean on call to %ZIS.
 CLEAN ;Cleanup env. Called from %ZISC also.
- I $G(IOT)'="SPL" K IO("DOC"),IO("SPOOL") ;(p446)
- I $G(IOT)'="HFS" K IO("HFSIO") ;p446
+ K IO("DOC"),IO("HFSIO"),IO("SPOOL") ;(p366)
  S (IOPAR,IOUPAR)=""
  Q
@@ -70,13 +66,9 @@
 RESETVAR ;Reset home IO* variables.
  I '$D(^XUTL("XQ",$J,"IO")) Q
- N %
- F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
- F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
- S POP=0,IO(0)=IO
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(^XUTL("XQ",$J,%))#2 S @%=^(%)
+ S POP=0,IO(0)=IO,(IOPAR,IOUPAR)=""
  Q
-SAVEVAR ;Save home IO* variables, called from XUS1,%ZTMS3
- N %
- F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY","IOPAR","IOUPAR" I $D(@%) S ^XUTL("XQ",$J,%)=@%
- F %="IO(""IP"")","IO(""CLNM"")","IO(""DOC"")","IO(""HFSIO"")","IO(""SPOOL"")" I $D(@%) S ^XUTL("XQ",$J,%)=@%
+SAVEVAR ;Save home IO* variables, called from XUS1
+ N % F %="IO","IOBS","IOF","IOM","ION","IOS","IOSL","IOST","IOST(0)","IOT","IOXY" I $D(@%) S ^XUTL("XQ",$J,%)=@%
  Q
 ZISLPC Q  ;No longer called in Kernel v8.
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS1.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;1/24/08  16:06
- ;;8.0;KERNEL;**18,49,69,104,112,199,391,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS1 ;SFISC/AC,RWF -- DEVICE HANDLER (DEVICE INPUT) ;07/07/2005  15:48
+ ;;8.0;KERNEL;**18,49,69,104,112,199,391**;JUL 10, 1995
 MAIN ;Called from %ZIS with a GO
  I '$D(IOP),$D(^%ZIS(1,%E,0)),'$P(^(0),"^",3) S %A=%H,%Z=^(0) D L2^%ZIS2 G EXIT
@@ -7,8 +6,9 @@
  I '$D(IOP),$D(IO("Q")),POP D AQUE^%ZIS3 K:%=2 IO("Q") S:%=2 %ZISB=$S(%IS'["N":2,1:0) I %=-1 S POP=1 G EXIT
  S %E=%H,POP=0,%IS=%ZIS ;Reset %IS from %ZIS
- I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,$C(7),"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
+ I %IS'["Q",$D(XQNOGO) S POP=1 W:'$D(IOP) !,*7,"OUTPUT IS NEVER ALLOWED FOR THIS OPTION" G EXIT
  D IOP:$D(IOP),R:'$D(IOP)
  G EXIT:$D(DTOUT)!$D(DUOUT)!(POP&$D(IOP)),L1:POP&'$D(IOP)
  D LKUP I %A'>0 S POP=1 D:'$D(DUOUT) MSG1 K DUOUT
+ I POP G EXIT:$D(IOP),L1:'$D(IOP)
  I '$D(^%ZIS(1,%A,0)) D MSG1 K %ZISIOS S POP=1
  I POP G EXIT:$D(IOP),L1:'$D(IOP)
@@ -16,18 +16,14 @@
  I $D(%ZIS("S")) N Y S Y=%E D XS^ZISX S:'$T POP=1 G G:POP
  W:'$D(IOP)&($P(%Z,"^",2)'=$I)&($P(%Z1,"^")]"") "  ",$P(%Z1,"^")
- D L2^%ZIS2 ;Call
+ D L2^%ZIS2
 G G L1:POP&'$D(IOP)&'($D(DTOUT)!$D(DUOUT)) ;Didn't get it
+ ;For type[TRM reset $X & $Y
+ I 'POP,%ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
  ;
-EXIT ;
- I POP G EX2 ;Did not get the device.
- ;For type[TRM reset $X & $Y
- I %ZTYPE["TRM",IO]"",$D(IO(1,IO)) U IO S:'(IO=IO(0)&'$D(IO("S"))&'$D(ZTQUEUED)) $X=0,$Y=0
+EXIT I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
  ;Do count of number of times device opened.  Field 51.
- I $L($G(IO)),$D(IO(1,IO))#2,$G(%ZISIOS) D
+ I $L($G(IO)),$D(IO(1,IO))#2,'POP,$G(%ZISIOS) D
  . S $P(^(5),"^",1)=$P($G(^%ZIS(1,%ZISIOS,5)),"^",1)+1
- I %ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
- I '$D(IO("Q")),$D(%ZISLOCK) S ^XUTL("XQ",$J,"lock",%ZISIOS)=%ZISLOCK
- I $D(IO)#2,IO]"",$D(IO(1,IO))#2,$D(%Z1),$P(%Z1,"^",11) S IO(1,IO,"NOFF")=1
-EX2 ;
+ I 'POP,%ZIS["H" S IO(0)=IO,IO("HOME")=%ZISIOS_"^"_IO ;Make home device
  I %IS'[0,$G(IO(0))]"" U IO(0) ;Make sure return with home active
  G SETVAR:'POP!(%IS["T"),KILVAR
@@ -37,5 +33,5 @@
  S %IS=%IS_%X K IOP W %X D SETQ Q
  ;Get ready to ask user for device
-R I %IS["Q",$D(XQNOGO) W !,$C(7),"AT THIS TIME, OUTPUT MUST BE QUEUED"
+R I %IS["Q",$D(XQNOGO) W !,*7,"AT THIS TIME, OUTPUT MUST BE QUEUED"
  S %A=$S($D(%IS("B")):%IS("B"),1:"HOME") ;Setup default
  I %IS["P",%A="HOME",$D(^%ZIS(1,%E,99)),$D(^%ZIS(1,+^(99),0)) S %A=$P(^(0),"^",1)
@@ -60,5 +56,5 @@
  I %X'=%ZISVT S %ZISVT=%X D VTLKUP^%ZIS S %A=%E Q:%A>0  ;uppercase lookup
  N %XX,%YY S %XX=%X D 1^%ZIS5 S %A=+%YY Q
-SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W $C(7) S DTOUT=1 Q
+SBR K DFOUT,DTOUT,DUOUT R %X:$S($D(DTIME)#2:DTIME,1:300) E  W *7 S DTOUT=1 Q
  S:%X="."!(%X="^") DUOUT=1,%X="" Q
 LC S %X=$$UP(%X)
@@ -66,13 +62,10 @@
 LOW(%) Q $TR(%,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
 UP(%) Q $TR(%,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- ;
- ;Call/Return % = 1 (yes), 2 (no) -1 (^)
-YN W "? ",$P("Yes// ^No// ",U,%)
-RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W $C(7)
+YN W "? ",$P("YES// ^NO// ",U,%)
+RYN R %X:$S($D(DTIME):DTIME,$D(%ZISDTIM):%ZISDTIM,1:300) E  S DTOUT=1,%X=U W *7
  S:%X]""!'% %=$A(%X),%=$S(%=89:1,%=121:1,%=78:2,%=110:2,%=94:-1,1:0)
- I '%,%X'?."?" W $C(7),"??",!?4,"ANSWER 'Yes' OR 'No': " G RYN
- W:$X>73 ! W $P("  (Yes)^  (No)",U,%)
- Q
-MSG1 I '$D(IOP) W ?20,$C(7),"  [DEVICE DOES NOT EXIST]"
+ I '%,%X'?."?" W *7,"??",!?4,"ANSWER 'YES' OR 'NO': " G RYN
+ W:$X>73 ! W $P("  (YES)^  (NO)",U,%) Q
+MSG1 I '$D(IOP) W ?20,*7,"  [DEVICE DOES NOT EXIST]"
  Q
 SETVAR ;Come here to setup the variables for the selected device
@@ -84,6 +77,5 @@
  S IOT=%ZTYPE,IOST(0)=%ZISIOST(0),IOST=%ZISIOST,IOPAR=%ZISOPAR,IOUPAR=%ZISUPAR,IOHG=%ZISHG
  S:IOF="" IOF="#" ;See that IOF has something
- K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU
- G KIL
+ K IOCPU S:$D(%ZISCPU) IOCPU=%ZISCPU G KIL
  ;
 KILVAR ;Come here to restore the calling variables
@@ -97,6 +89,5 @@
  S:%IS["T" IO("T")=1 K %ZIS,%IS,%A,%E,%H,%ZISOS,%ZISV,IOP
 K2 K %I,%X,%Y,%Z,%Z1,%Z91,%Z95,%ZTYPE,%ZTIME
- K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM
- K %ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
- K %ZISMY,%ZISQUIT,%ZISLOCK
+ K %ZISCHK,%ZISCPU,%ZISI,%ZISR,%ZISVT,%ZISB,%ZISX,ZISI,%ZISHGL,%ZISHP,%ZISIO,%ZISIOS,%ZISIOM,%ZISIOF,%ZISIOSL,%ZISIOBS,%ZISIOST,%ZISIOST(0),%ZISTO,%ZISTP,%ZISHG,%ZISSIO,%ZISOPEN,%ZISOPAR,%ZISUPAR
+ K %ZISMY,%ZISQUIT
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS2.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;1/24/08  16:07
- ;;8.0;KERNEL;**69,104,112,118,136,241,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS2 ;SFISC/AC,RWF -- DEVICE HANDLER (CHECKS) ;06/12/2002  15:41
+ ;;8.0;KERNEL;**69,104,112,118,136,241**;JUL 10, 1995
 HUNT S:'$D(%ZISHP) %ZISHP=%E,%ZISHGL=0 S %E=0
  F  S %ZISHGL=$O(^%ZIS(1,%ZISHG(0),"HG",%ZISHGL)) Q:%ZISHGL'>0  D  Q:%E
@@ -12,9 +11,6 @@
 L2 ;Entry point from %ZIS1
  I $D(DTOUT)!$D(DUOUT) K %ZISHP,%ZISHPOP Q
-CHECK ;Get IO check for secondary $I
- K %ZISCPU N %Z2
- S POP=0,%Z=^%ZIS(1,%E,0),%Z2=$S(%ZIS("PRI")=1:"",1:$G(^%ZIS(1,%E,2))) ;Get Primary and secondary IO.
- S IO=$S(%ZIS("PRI")=1:$P(%Z,"^",2),$L($P(%Z2,"^")):$P(%Z2,"^"),1:$P(%Z,"^",2)) ;
- S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing
+CHECK K %ZISCPU S POP=0,%Z=^%ZIS(1,%E,0),IO=$P(%Z,"^",2)
+ S:%IS["Q"&'$D(ZTQUEUED)&($P(%Z,"^",12)=1!$D(XQNOGO)) %ZISB=0,IO("Q")=1 ;Forced Queueing 
  I $P(%Z,"^",12)=2 S %IS=$TR(%IS,"Q") I $D(IO("Q")) D  Q
  . I '$D(IOP) W !,"Queuing NOT ALLOWED on this device"
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS3.m	(revision 636)
@@ -1,35 +1,25 @@
-%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;1/24/08  13:18
- ;;8.0;KERNEL;**18,36,69,104,391,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
- ;Call with a Go from ^%ZIS2
- I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E) ;Pre-Open
+%ZIS3 ;SFISC/AC,RWF -- DEVICE HANDLER(DEVICE TYPES & PARAMETERS) ;10/06/2005  13:23
+ ;;8.0;KERNEL;**18,36,69,104,391**;JUL 10, 1995
+ I %ZIS'["T",$G(^%ZIS(1,+%E,"POX"))]"" D XPOX^ZISX(%E)
  I $D(%ZISQUIT) S POP=1 K %ZISQUIT
  S %ZISCHK=1
- ;I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
- ;See if need to lock.
- K %ZISLOCK
- I %ZIS'["T",+$G(^%ZIS(1,+%E,"GBL")) S %ZISLOCK=$NA(^%ZIS("lock",IO))
- ;
- I 'POP G TRM:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
- ;
-Q ;%ZIS6 Returns here
- ;See if need to un-lock.
- I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
+ I 'POP&(%ZISB)&(%ZTYPE'="RES")&(%ZTYPE'="OTH")&(%ZTYPE'="SDP")&(IO'["::") D DEVOK
+ G Q:POP
+ G @%ZTYPE:(%ZTYPE["TRM"),@(%ZTYPE_"^%ZIS6") ;Jump to next part
+ ; 
+Q I $D(%ZISUOUT) K %ZISUOUT,%ZISHP,%ZISHPOP Q
  I $D(%ZISHPOP)&$S(IO="":1,1:'$D(IO(1,IO))) D HGBSY^%ZIS2 Q
- I POP S:%ZIS'["T" IO="" I $D(%ZISHG(0)),%ZIS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
- Q  ;Return to %ZIS1
- ;
+ I POP S:%IS'["T" IO="" I $D(%ZISHG(0)),%IS'["D",'$D(%ZISHPOP) G HUNT^%ZIS2
+ Q
 VTRM ;Virtual terminal type
-TRM ;D OPEN^%ZIS4:'POP&(%ZISB&(%ZIS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
- D MARGN:'POP,SETPAR:'POP ;Terminal type// TEST CHANGE
- I 'POP,%ZIS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%ZIS["Q" D AQUE
- W:'$D(IOP) !
- I '$D(IO("Q")),'POP,%ZISB,%ZIS'["T" D O^%ZIS4
+TRM D OPEN^%ZIS4:'POP&(%ZISB&(%IS'["T")),MARGN:'POP,SETPAR:'POP ;Terminal type
+ I 'POP,%IS'["T",%ZISB=1,'$D(IOP),IO'=IO(0),'$D(IO("Q")),%IS["Q" D AQUE
+ W:'$D(IOP) ! I '$D(IO("Q")) D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
  G Q
-DEVOK N X,Y,X1 ;Not sure this is needed
+DEVOK N X,Y,X1
  S X=IO,X1=%ZTYPE
  D DEVOK^%ZOSV I Y=-99!(Y=0)!(Y=$J) Q
- I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,$C(7),"[Device Unavailable]" Q
- I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,$C(7),"[Device does not Exist or Unavailable]" Q
+ I Y>0 S POP=1 W:'$D(IOP)&('$D(%ZISHG(0))!(%IS["D")) !,*7,"[Device Unavailable]" Q
+ I Y=-1 S IO="",POP=1 W:'$D(IOP)&('$D(ZISHG(0))!(%IS["D")) !,*7,"[Device does not Exist or Unavailable]" Q
  Q
  ;
@@ -49,8 +39,7 @@
  S POP=1 I %ZISB&(%ZTYPE["TRM")&(IO'=IO(0)) C IO K IO(1,IO) Q
  Q
-SETPAR S:$L(%ZISOPAR)&($E(%ZISOPAR)'="(") %ZISOPAR="("_%ZISOPAR_")"
+SETPAR S:%ZISOPAR]""&($A(%ZISOPAR)-40) %ZISOPAR="("_%ZISOPAR_")"
  Q
-AQUE ;Ask about Queueing
- W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
+AQUE W ! S %=$S($D(IO("Q")):1,1:2),U="^",%ZISDTIM=60
  I $D(IO("Q")) W !,"Previously, you have selected queueing."
  W !,"Do you "_$S($D(IO("Q")):"STILL ",1:"")_"want your output QUEUED"
@@ -58,5 +47,4 @@
  I %=-1 S POP=1,%ZISHPOP=1,%ZISUOUT=1 C IO K IO(1,IO) Q
  I %=1 S IO("Q")=1 C IO K IO(1,IO) Q
- ;I %=2 K IO("Q")
  Q
 ST(%ZISTP) ;
@@ -81,2 +69,3 @@
  S:IOST="" IOST="P-OTHER",IOST(0)=0
  Q
+ 
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS4.m	(revision 636)
@@ -1,5 +1,5 @@
-%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;1/24/08  16:08
- ;;8.0;KERNEL;**275,425,440**;Jul 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS4 ;ISF/RWF,DW - DEVICE HANDLER SPECIFIC CODE (GT.M for Unix/VMS) ;03/07/2007
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;
 OPEN ;From %ZIS3 for TRM
  G OPN2:$D(IO(1,IO))
@@ -13,18 +13,19 @@
  Q
  ;Why no open paraneters???
-OP1 N $ET S $ET="G OPNERR^%ZIS4"
- I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
- O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1
+OP1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O IO::%ZISTO S:$T IO(1,IO)="" S:'$T POP=1 L:$D(%ZISLOCK) -@%ZISLOCK
  Q
 OPNERR ;Open Error
- S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC=""
- Q
+ S POP=1,IO("LASTERR")=$G(IO("ERROR")),IO("ERROR")=$$EC^%ZOSV,$EC="" Q
  ;
-O ;From %ZIS6 for all types.
+O ;From %ZIS6 for other types.
  D:%IS["L" ZIO
- I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX ;Open Printer Port
+LCKGBL ;Lock Global
+ I %ZTYPE="CHAN" N % S %=$G(^%ZIS(1,+%E,"GBL")) I $L(%) L @("+^"_%_":0") S:'$T POP=1 I POP W:'$D(IOP) !,?5,*7,"[DEVICE IS BUSY]" Q
+ I $D(IO("S")),$D(^%ZIS(2,IO("S"),10)),^(10)]"" U IO(0) D X10^ZISX
 OPAR I $D(IOP),%ZTYPE="HFS",$D(%IS("HFSIO")),$D(%IS("IOPAR")),%IS("HFSIO")]"" S IO=%IS("HFSIO"),%ZISOPAR=%IS("IOPAR")
  I %ZTYPE="CHAN" D TCPIP Q:POP  G OXECUTE^%ZIS6
- S %A=%ZISOPAR_$S(%ZISOPAR["):":"",1:":"_%ZISTO)
+ S %A=%ZISOPAR_$S(%ZISOPAR["):":"",%ZTYPE["CHAN"&($P(%ZTIME,"^",3)="n"):"",1:":"_%ZISTO)
  N % S %(IO)="",%=$P($P($NA(%(IO)),"(",2),")")
  S %A=%_$E(":",%A]"")_%A
@@ -39,6 +40,6 @@
  ;
 O1 N $ES,$ET S $ET="G OPNERR^%ZIS4"
- I $D(%ZISLOCK) L +@%ZISLOCK:5 E  S POP=1 Q
- O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)=""
+ L:$D(%ZISLOCK) +@%ZISLOCK:60
+ O @%A S:'$T&(%A?.E1":".N) POP=1 S:'POP IO(1,IO)="" L:$D(%ZISLOCK) -@%ZISLOCK
  S IO("ERROR")="" Q
  ;
@@ -53,5 +54,5 @@
  Q
  ;
-TCPIP ;For TCP/IP devices, should use ^%ZISTCP
+TCPIP ;For TCP/IP devices
  N %S
  S %ZISTO=$G(%ZISTO,3)
@@ -66,7 +67,6 @@
  I $D(ZISDA) W:'$D(IOP) !?5,*7,"You may not Spool the printing of a Spool document" G N
  I $D(DUZ)[0 W:'$D(IOP) !,"Must be a valid user." G N
-R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0
- S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
- G:'%ZISB OK I '$P(%ZY,"^",3),$L(%ZFN) O %ZFN:(append:nowrap):2 G DOC
+R S %ZY=-1 D NEWDOC^ZISPL1 G N:%ZY'>0 S %ZDA=+%ZY,%ZFN=$P(%ZY(0),U,2),IO("DOC")=$P(%ZY(0),U,1) G OK:$D(IO("Q"))
+ G:'%ZISB OK I '$P(%ZY,"^",3),%ZFN]"" D SPL3 G N:%ZFN']"",DOC
  S %ZFN=IO_"SPOOL_no_"_%ZDA_".TMP" D SPL2 G:%ZFN']"" N S $P(^XMB(3.51,%ZDA,0),U,2)=%ZFN,^XMB(3.51,"C",%ZFN,%ZDA)=""
 DOC S IO=%ZFN,IO("SPOOL")=%ZDA,^XUTL("XQ",$J,"SPOOL")=%ZDA,IOF="#"
@@ -74,19 +74,13 @@
 OK K %ZDA,%ZFN Q
 N K %ZDA,%ZFN,IO("DOC") S POP=1 Q
- ;
-SPL2 ;Open for write
- O %ZFN:(newversion:noreadonly:nowrap:exception="G SPL4"):2 G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
- ;
-SPL3 ;Open for Read
- O %ZFN:(readonly:exception="G SPL4"):2 S:'$T ZISPLQ=1 G:'$T SPL4 S IO(1,%ZFN)="" Q
+SPL2 O %ZFN:(NEWVERSION:WORLD=RWD) G:$ZA<0 SPL4 S IO(1,%ZFN)="" Q
+SPL3 N X S X="SPL4^%ZIS4",@^%ZOSF("TRAP")
+ O %ZFN:READONLY:1 S:'$T ZISPLQ=1 G:$ZA<0!('$T) SPL4 S IO(1,%ZFN)="" Q
 SPL4 W:'$D(IOP)&'$D(ZTQUEUED) !?5,*7,"Couldn't open the spool file." S %ZFN="" Q
- ;
-CLOSE ;Close out the spool
- N %,%1,%Z1,%ZFN,%ZS,%ZDA,XS,%Y,%X
- I $L(IO) C IO K IO(1,IO)
- D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
- S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  S %ZCR=$C(13),%Y=""
- S %Z1=+$G(^XTV(8989.3,1,"SPL")),%=0
- U %ZFN F  R %X#255:5 Q:$ZEOF  S %2=%X D CL2 Q:%Z1<%
+CLOSE N %Z1 C:IO]"" IO K:IO]"" IO(1,IO) D FILE^ZISPL1 I %ZDA'>0 K ZISPLAD Q
+ S %ZFN=$P(%ZS,"^",2) D SPL3 Q:%ZFN']""  U %ZFN S %ZCR=$C(13),%Y="",X="SPLEOF^%ZIS4",@^%ZOSF("TRAP")
+ S %Z1=+$G(^XTV(8989.3,1,"SPL"))
+ F %=0:0 R %X#255:5 Q:$ZA<0  S %2=%X D CL2 G:%Z1<% SPLEX
+SPLEOF I $ZE'["ENDO" Q  ;Send error up
 SPLEX C %ZFN:(DELETE) K:%ZFN]"" IO(1,%ZFN) D CLOSE^ZISPL1 K %Y,%X,%1,%ZFN Q
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZIS6.m	(revision 636)
@@ -1,10 +1,7 @@
-%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;1/24/08  16:09
- ;;8.0;KERNEL;**24,49,69,118,127,136,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZIS6 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;02/04/2000  08:14
+ ;;8.0;KERNEL;**24,49,69,118,127,136**;JUL 10, 1995
  ;Expect that IO is current device
-OXECUTE ;Open Execute
- I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
-ANSBAK ;Answer Back
- I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
+OXECUTE I $D(^%ZIS(2,%ZISIOST(0),2))=1 S %Y=^(2) D 2
+ANSBAK I $D(^%ZIS(2,%ZISIOST(0),102)) S %Y=^(102) D 2 E  S POP=1 D:'$D(IOP) SAY($C(7)_"[NOT ON LINE]") C:%ZISB IO K IO(1,IO) G QUIT
  I $D(%ZISMTR) X ^%ZOSF("MAGTAPE") U IO W:$D(%MT("REW")) @%MT("REW") U IO(0) K %MT
  G QUIT:'$D(IO("P"))
@@ -63,17 +60,13 @@
 HG ;
  Q
-SPL ;Spool type
- N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T"
+SPL N %E,%Z D MARGN^%ZIS3 W:'$D(IOP) ! D SPOOL^%ZIS4:%IS'["T" ;Spool type
  G Q
 MT D MARGN^%ZIS3,ASKPAR,AMTREW:'POP&'$D(IOP)&%ZISB W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Magtape type
  G Q
-SDP ;Sequential disk processor type
- D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+SDP D MARGN^%ZIS3,ASKPAR W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Sequential disk processor type
  G Q
-HFS ;Host File Server type
- D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+HFS D MARGN^%ZIS3,HFS^%ZIS4 W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Host File Server type
  G Q
-RES ;Resources
- G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q
+RES G Q:%IS["T" N X,X1 I %IS'["R"!'$D(IOP) S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q  ;Resources
  G Q:$D(IO(1,IO)) I %IS["T" S X=IO,X1="RES" D DEVOK^%ZIS3 S:Y POP=1 G Q:POP
  D:%ZISB RES1 G Q
@@ -84,18 +77,12 @@
 IMPC ;Imaging Work Station
 BAR ;Bar Code
-OTH ;Other Device type
- D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T"))
+OTH D MARGN^%ZIS3:'POP,ASKPAR:'POP W:'$D(IOP) ! D O^%ZIS4:'POP&(%ZISB&(%IS'["T")) ;Other Device type
  G Q
  ;
-ASKPAR ;Ask Parameters
- G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
+ASKPAR G SETPAR^%ZIS3:$D(IOP),SETPAR^%ZIS3:'$P(^%ZIS(1,%E,0),"^",4) W "  ADDRESS/PARAMETERS: " W:%ZISOPAR]"" %ZISOPAR_"// " D SBR^%ZIS1 D MSG1:%X="?" G ASKPAR:%X="?" S:%X]"" %ZISOPAR=%X I $D(DTOUT)!$D(DUOUT) S POP=1
  I POP,%ZISB&(%ZTYPE["TRM") C IO K IO(1,IO) Q
  Q:POP  G SETPAR^%ZIS3
+AMTREW I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
+ S:%=1 %ZISMTR=1 Q
+MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25 Q
  ;
-AMTREW ;Mag Tape Rewind
- I %ZISB,%ZTYPE="MT",'$D(IOP) W "  REWIND" S %=2,U="^",%ZISDTIM=60 D YN^%ZIS1 K %ZISDTIM G AMTREW:%=0 I %=-1 S POP=1 Q
- S:%=1 %ZISMTR=1
- Q
-MSG1 W !?5,"Enter the desired parameters needed to open the selected device.",!?25
- Q
- ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISC.m	(revision 636)
@@ -1,5 +1,4 @@
-%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;1/24/08  16:09
- ;;8.0;KERNEL;**24,36,49,69,199,216,275,409,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
+%ZISC ;SFISC/GFT,AC,MUS - CLOSE LOGIC FOR DEVICES  ;01/14/2002  09:06
+ ;;8.0;KERNEL;**24,36,49,69,199,216,275,409**;JUL 10, 1995;Build 3
 C0 ;
  N %,%E,%H,%ZISI,%ZISOS,%ZISX,%ZISV
@@ -42,7 +41,9 @@
  . U:$S($D(ZTQUEUED):0,'$L($G(IO(0))):0,$D(IO(1,IO(0)))#2:1,1:0) IO(0)
  . C IO K IO(1,IO) S IO("CLOSE")=IO ;close device
- ;Unlock global used to control access.
- S %=$G(^XUTL("XQ",$J,"lock",+$G(IOS))) I $L(%) L -@% K ^XUTL("XQ",$J,"lock",IOS)
  ;
+ ;
+ I $D(IOT),IOT="CHAN",$D(IOS) D
+ .S %=$G(^%ZIS(1,+IOS,"GBL"))
+ .I %]"" L @("-^"_%) ;unlock global used to control access to network channels.
  I $D(IO("SPOOL")) D CLOSE^%ZIS4 ;Special close for spool device
  ;
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZISS1.m	(revision 636)
@@ -1,15 +1,9 @@
-%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;1/24/08  16:10
- ;;8.0;KERNEL;**69,440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
-VALID ;
- N %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- D L
+%ZISS1 ;AC/SFISC - Collect screen parameters 5/29/88  2:02 PM ;11/05/97  08:40
+ ;;8.0;KERNEL;**69**;JUL 10, 1995
+VALID D L K %ZISI,%ZISNP,ZISCH,ZISEND,ZISNUM,ZISQ,ZISXL,ZISXLN Q
+ ;
+SET2 S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
  Q
- ;
-SET2 ;
- S %ZISFN="" F %ZISZ=0:0 S %ZISFN=$O(%ZISZ(%ZISFN)) Q:%ZISFN=""  I $D(%ZISZ(%ZISFN))#2 S %ZISXX=%ZISZ(%ZISFN) D INDCK
- Q
-INDCK ;
- S %ZISY=""
+INDCK S %ZISY=""
  I "IOEFLD^IOSTBM"[%ZISFN S @%ZISFN=%ZISXX Q
  I %ZISXX]"" S @("%ZISY="_%ZISXX)
@@ -18,30 +12,25 @@
  E  S @("IO"_$E(%ZISFN,1,6))=%ZISY
  Q:'$D(%ZIS)#2  Q:%ZIS'["I"  Q:'$D(%ZISZ(%ZISFN,1))
- ;
-SRAY ;
- S %=%ZISY,%ZISY=$A($E(%ZISY,1))
+SRAY S %=%ZISY,%ZISY=$A($E(%ZISY,1))
  F %1=2:1:$L(%) S %ZISY=%ZISY_$S($A(%,%1)<32:$A(%,%1),$A(%,%1)=127:127,1:$E(%,%1))
  S IOIS(%ZISY)=%ZISFN
  Q
 CHECK ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
- S %ZISXX=X D L S X=%ZISYY
+ S %ZISXX=X D L S X=%ZISYY K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
  Q
 CHECK1 ;Entry point called from input transforms of fields in DEV/TT files.
- N %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN ;p440
  S %ZISXX=$S(X?1"W ".E:$E(X,3,$L(X)),1:X)
- D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY)
+ D L S X=$S(X?1"W ".E:"W "_%ZISYY,1:%ZISYY) K %ZISXX,%ZISYY,%ZISI,%ZISNP,%ZISX1,%ZISX2,ZISCH,ZISNUM,ZISQ,ZISXL,ZISXLN
  Q
 FORM ;Entry point called from input transforms of fields in DEV/TT files.
  Q:$L(X,"_")'>1
- N %ZISSI,%ZISSY ;p440
  ;F %ZISSI=1:1:$L(X,"_") S %ZISX1=$P(X,"_",%ZISSI) I %ZISX1]"","#?!"[$E(%ZISX1) S X=$S(%ZISSI=1:"",1:$P(X,"_",1,%ZISSI-1)_",")_%ZISX1_$S(%ZISSI<$L(X,"_"):","_$P(X,"_",%ZISSI+1,255),1:"") W !,%ZISSI_"==>"_X
  S %ZISSY=""
  F %ZISSI=1:1:$L(X,"_") S %ZISSY=%ZISSY_$P(X,"_",%ZISSI)_$S($P(X,"_",%ZISSI+1)="":"","#?!"[$E($P(X,"_",%ZISSI+1)):",","#?!"[$E($P(X,"_",%ZISSI)):",",1:"_")
- S X=%ZISSY
+ S X=%ZISSY K %ZISSI,%ZISSY
  Q
  ;
 L S ZISQ="""",%ZISNP=0,ZISXLN=$L(%ZISXX) I 'ZISXLN S %ZISYY="" Q
- S ZISXL=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
+ S (ZISXL)=0,%ZISYY="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) D L1 Q:ZISXL'<ZISXLN
  ;I $L(%ZISYY,"$C(")>2,%ZISYY[")_$C(" S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX Q
  S %ZISXX=%ZISYY D L2,L3 S %ZISYY=%ZISXX
@@ -52,13 +41,8 @@
  I ZISCH="*" D STAR Q
  I ZISCH="(" D PAREN Q
- S %ZISYY=%ZISYY_ZISCH
+ S %ZISYY=%ZISYY_ZISCH Q
+L2 F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
  Q
-L2 ;Find $C(x)_$C(y) and merge
- N I ;p440
- F I=1:1:$L(%ZISXX,"_") S %ZISX1=$P(%ZISXX,"_",I),%ZISX2=$P(%ZISXX,"_",I+1) I $E(%ZISX1,1,3)="$C(",$E(%ZISX2,1,3)="$C(" D S2
- Q
-L3 ;
- N I
- F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
+L3 F I=1:1:$L(%ZISXX,"_") I $P(%ZISXX,"_",I)["+","$("'[$E($P(%ZISXX,"_",I)),")"'[$E($P(%ZISXX,"_",I),$L($P(%ZISXX,"_",I))) S $P(%ZISXX,"_",I)="("_$P(%ZISXX,"_",I)_")"
  Q
 STAR ;S ZISNUM="" F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL) S:ZISCH?1N ZISNUM=ZISNUM_ZISCH I ZISCH=""!(ZISCH=",") S %ZISYY=%ZISYY_"$C("_+ZISNUM_")",ZISXL=ZISXL-1 Q
@@ -67,11 +51,9 @@
 QUOTE S %ZISYY=%ZISYY_ZISCH F %ZISI=0:0 S ZISXL=ZISXL+1 S ZISCH=$E(%ZISXX,ZISXL),%ZISYY=%ZISYY_ZISCH I ZISCH=ZISQ!(ZISXL'<ZISXLN) Q
  Q
-DOLR ;Looking for $C.
+DOLR ;LOOKING FOR $C.
  I "IXY"[$E(%ZISXX,ZISXL+1) S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1) S ZISXL=ZISXL+1 Q
- I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN Q
- S %ZISYY=%ZISYY_"$" ;p440
+ I "ACDEFJLNOPRSTV"[$E(%ZISXX,ZISXL+1)&($E(%ZISXX,ZISXL+2)="(") S %ZISYY=%ZISYY_"$"_$E(%ZISXX,ZISXL+1),ZISXL=ZISXL+2 D PAREN
  Q
-PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1
- Q
+PAREN S %ZISYY=%ZISYY_"(",ZISEND=")",%ZISNP=%ZISNP+1 D SCAN S %ZISNP=%ZISNP-1 Q
 SCAN F %ZISI=0:0 S ZISXL=ZISXL+1,ZISCH=$E(%ZISXX,ZISXL) D S1 Q:ZISXL'<ZISXLN!(ZISEND=ZISCH&(%ZISNP))
  Q
@@ -79,6 +61,5 @@
  I ZISCH="$" D DOLR Q
  I ZISCH="(" D PAREN Q
- S %ZISYY=%ZISYY_ZISCH
- Q
+ S %ZISYY=%ZISYY_ZISCH Q
  ;
 S2 ;MERGE $C
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZOSV2.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZOSV2.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZOSV2.m	(revision 636)
@@ -1,4 +1,21 @@
 %ZOSV2 ;ISF/RWF - More GT.M support routines ;10/18/06  14:29
- ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 18
+ ;;8.0;KERNEL;**275,425**;Jul 10, 1995;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 
  Q
  ;SAVE: DIE open array reference.
@@ -25,6 +42,6 @@
  S $ETRAP="S $ECODE="""" Q"
  S %I=$I,%DIR=$$RTNDIR^%ZOSV,RN=$TR(RN,"%","_")
- I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "DEL "_%DIR_X_".m;*"
- I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "DEL "_%DIR_X_".obj;*"
+ I $L($ZSEARCH(%DIR_RN_".m",244)) ZSYSTEM "rm -f "_%DIR_X_".m"
+ I $L($ZSEARCH(%DIR_RN_".obj",244)) ZSYSTEM "rm -f "_%DIR_X_".obj"
  I $L($ZSEARCH(%DIR_RN_".o",244)) ZSYSTEM "rm -f "_%DIR_X_".o"
  Q
Index: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZTLOAD4.m
===================================================================
--- FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZTLOAD4.m	(revision 631)
+++ FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/_ZTLOAD4.m	(revision 636)
@@ -1,12 +1,11 @@
-%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;1/24/08  16:15
- ;;8.0;KERNEL;**440**;JUL 10, 1995;Build 13
- ;Per VHA Directive 2004-038, this routine should not be modified
- ;Call with ZTSK, [ZTCPU]; Return ZTSK()
+%ZTLOAD4 ;SEA/RDS-TaskMan: P I: Is Queued? ;7/26/91  11:55 ;
+ ;;8.0;KERNEL;;JUL 10, 1995
+ ;;7.0;
+ ;
 INPUT ;check input parameters for error conditions
- N %,$ES,$ET,%ZTVOL,ZTREC,ZTD,ZT1,ZT2,ZT3
  I $D(ZTSK)[0 S ZTSK=""
- I $D(ZTSK)>1 S %=ZTSK K ZTSK S ZTSK=%
+ I $D(ZTSK)>1 S ZTLOAD=ZTSK K ZTSK S ZTSK=ZTLOAD K ZTLOAD
  I ZTSK<1!(ZTSK\1'=ZTSK) S ZTSK="",ZTSK(0)="",ZTSK("E")="IT" G QUIT
- S ZTSK(0)="",ZTSK("E")="U",$ET="Q:$ES  S $EC="""" G QUIT^%ZTLOAD4"
+ S ZTSK(0)="",ZTSK("E")="U",X="QUIT^%ZTLOAD3",@^%ZOSF("TRAP")
  S %ZTVOL=^%ZOSF("VOL")
  I $D(ZTCPU)[0 S ZTCPU=%ZTVOL
@@ -15,19 +14,18 @@
  ;
 HERE ;lookup task's status on current volume set
- L +^%ZTSK(ZTSK):1
- I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
- S ZTREC=^%ZTSK(ZTSK,0),ZTD=$G(^(.04))
- S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6) ;scheduled $H
+ L +^%ZTSK(ZTSK) I $D(^%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
+ S ZTREC=^%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  ;
- S ZT1="" F  S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="IO",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="JOB",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="LINK",ZT2="" F  S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0
  ;
 QUIT ;cleanup and quit
- L:ZTSK -^%ZTSK(ZTSK) ;K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
+ L:ZTSK -^%ZTSK(ZTSK) K %ZTCPU,%ZTM,%ZTM1,%ZTM2,%ZTMAST,%ZTVOL,X,Y,ZT,ZT1,ZT2,ZT3,ZTCPU,ZTD,ZTREC
  I ZTSK(0)]"" K ZTSK("E") Q
  I ZTSK("E")'="U" Q
@@ -36,5 +34,4 @@
  ;
 THERE ;rest of code looks up task's status on some other volume set
- N %ZTCPU,%ZTM,X,Y
  ;
 FILES ;find TaskMan files on the volume set to be searched
@@ -48,13 +45,13 @@
 SEARCH ;find out if task is queued on that volume set
  I $D(^[X,Y]%ZTSK(ZTSK,0))[0 S ZTSK("E")="I" G QUIT
- S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$G(^(.04))
- S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=$P(ZTREC,U,6)
+ S ZTREC=^[X,Y]%ZTSK(ZTSK,0),ZTD=$P(ZTREC,U,6)
+ S ZTSK("DUZ")=$P(ZTREC,U,3),ZTSK("D")=ZTD
  I ZTD]"",$D(^[X,Y]%ZTSCH(ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  I ZTD]"",$D(^[X,Y]%ZTSCH("JOB",ZTD,ZTSK))#2 S ZTSK(0)=1 G QUIT
  ;
- S ZT1="" F  S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="IO",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="JOB",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
- S ZT1="LINK",ZT2="" F  S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F  S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="" F ZT=0:0 S ZT1=$O(^[X,Y]%ZTSCH(ZT1)) Q:'ZT1  I $D(^(ZT1,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="IO",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="JOB",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)) Q:ZT2=""  I $D(^(ZT2,ZTSK))#2 S ZTSK(0)=1 G QUIT
+ S ZT1="LINK",ZT2="" F ZT=0:0 S ZT2=$O(^[X,Y]%ZTSCH(ZT1,ZT2)),ZT3="" Q:ZT2=""  F ZT=0:0 S ZT3=$O(^[X,Y]%ZTSCH(ZT1,ZT2,ZT3)) Q:ZT3=""  I $D(^(ZT3,ZTSK))#2 S ZTSK(0)=1 G QUIT
  S ZTSK(0)=0 G QUIT
  ;
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR138PO.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR138PO.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR138PO.m	(revision 636)
@@ -1,4 +1,21 @@
 LR138PO ;DALISC/FHS - LR*5.2*138 POST INSTALL ROUTINE KIDS INSTALL
- ;;5.2;LAB SERVICE;**138**;Sep 27, 1994
+ ;;5.2;LAB SERVICE;**138**;Sep 27, 1994;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 EN ;Builds Laboratory OOS Locations for each LMIP valid WKLD Divison
  ;
@@ -15,5 +32,5 @@
  I 'LRPKG S LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
  I 'LRPKG D  G END
- .W !!$$CJ^XLFSTR("Not able to find 'LAB SERVICE' in your Package (#9.4) file.",80),!,$$CJ^XLFSTR("Contact your IRM Service !!",80),!!,$C(7) H 5 S XPDQUIT=2
+ .W !!,$$CJ^XLFSTR("Not able to find 'LAB SERVICE' in your Package (#9.4) file.",80),!,$$CJ^XLFSTR("Contact your IRM Service !!",80),!!,$C(7) H 5 S XPDQUIT=2
  . W !,$$CJ^XLFSTR("POST INSTALL ABORTED",80)
  W !!,$$CJ^XLFSTR("Creating Laboratory OOS Workload Locations",80),!!
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OB69.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OB69.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OB69.m	(revision 636)
@@ -1,4 +1,4 @@
 LR7OB69 ;slc/dcm/JAH - Get Lab order data from 69 - 68 - 63 ;8/10/04
- ;;5.2;LAB SERVICE;**121,187,224,291,373**;Sep 27, 1994;Build 1
+ ;;5.2;LAB SERVICE;**121,187,224,291**;Sep 27, 1994
  ;
 69(ODT,SN) ;Get data from file 69
@@ -33,5 +33,6 @@
  Q:'$D(^LR(+X0,0))  ;No matching entry in ^LR
  S:'$D(DFN) DFN=$P(^LR(+X0,0),"^",3) S:'$D(LRDFN) LRDFN=+X0 S:'$D(LRDPF) LRDPF=$P(^LR(+X0,0),"^",2)_$G(^DIC(+$P(^LR(+X0,0),"^",2),0,"GL"))
- S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",9),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2)
+ S Y1=+XP1,Y2=$S($P(X1,"^"):$P(X1,"^"),1:$P(X0,"^",8)),Y3=$P(X0,"^",3),Y4=$P(X0,"^",4),Y5=$P(X0,"^",5),Y6=$P(X0,"^",6),Y7=$P(X0,"^",7),Y8=$P(X3,"^"),Y9=$P(X3,"^",2),Y11=$P(X0,"^",11),Y12=$P(X0,"^",2)
+ S:$L(Y7) Y7=$O(^SC("C",Y7,0))
  ;canceled entries are skipped, so calls to this routine from options
  ;that are removing tests need to make the call before setting the pieces
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGG.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OGG.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGG.m	(revision 636)
@@ -1,4 +1,4 @@
 LR7OGG ;DALOI/STAFF- Interim report rpc grid ; Feb 9, 2005
- ;;5.2;LAB SERVICE;**187,290,364**;Sep 27, 1994;Build 3
+ ;;5.2;LAB SERVICE;**187,290**;Sep 27, 1994
  ;
 TEST ; test use only
@@ -32,5 +32,5 @@
  S ^TMP("LR7OGX",$J,"OUTPUT",1)="0^0^0^1"
  N ABCNT,ABDCNT,ABLINE,ABTCNT,ABTLINE,ADCNT,ADSEQ,AGE,ATCNT,ATSEQ,CDT,CHSUB,COMCNT,COMMENT,DATACNT,DATESEQ,DFN,EDATE,EDT,FLAG,IDT
- N LINE,LRCW,LRDFN,LRX,NUM,ONLYSPEC,OUTCNT,PNM,PRNTCODE,RESULT,SDATE,SEX,SPEC,SPECNAME,TESTNAME,TESTNUM,TESTSEQ,TESTZERO,X,ZERO,INEXACT,DISPDATE
+ N LINE,LRCW,LRDFN,LRX,NUM,ONLYSPEC,OUTCNT,PNM,PRNTCODE,RESULT,SDATE,SEX,SPEC,SPECNAME,TESTNAME,TESTNUM,TESTSEQ,TESTZERO,X,ZERO
  K ^TMP("LR7OG",$J)
  S DFN=+^TMP("LR7OGX",$J,"INPUT",1),SDATE=+$P(^(1),U,2),EDATE=+$P(^(1),U,3),ONLYSPEC=+$P(^(1),U,4)
@@ -56,5 +56,5 @@
  . S ZERO=^LR(LRDFN,"CH",IDT,0)
  . I '$P(ZERO,U,3) Q
- . S CDT=+ZERO,INEXACT=$P(ZERO,U,2),SPEC=+$P(ZERO,U,5),SPECNAME=$P($G(^LAB(61,SPEC,0)),U),COMMENT=$S($O(^LR(LRDFN,"CH",IDT,1,0)):"**",1:"")
+ . S CDT=+ZERO,SPEC=+$P(ZERO,U,5),SPECNAME=$P($G(^LAB(61,SPEC,0)),U),COMMENT=$S($O(^LR(LRDFN,"CH",IDT,1,0)):"**",1:"")
  . I ONLYSPEC,SPEC'=ONLYSPEC Q
  . S CHSUB=1
@@ -64,6 +64,5 @@
  . . . S DATESEQ=DATESEQ+1
  . . . S OUTCNT=OUTCNT+1
- . . . S DISPDATE=$S(INEXACT:CDT\1,1:CDT)
- . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=DATESEQ_U_CDT_U_SPEC_U_SPECNAME_U_COMMENT_U_DISPDATE
+ . . . S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)=DATESEQ_U_CDT_U_SPEC_U_SPECNAME_U_COMMENT
  . . . I COMMENT'="" D
  . . . . S COMCNT=COMCNT+1
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGMG.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OGMG.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGMG.m	(revision 636)
@@ -1,8 +1,8 @@
 LR7OGMG ;DALOI/STAFF- Interim report rpc memo grid ;July 19, 2006
- ;;5.2;LAB SERVICE;**187,230,286,290,331,364**;Sep 27, 1994;Build 3
+ ;;5.2;LAB SERVICE;**187,230,286,290,331**;Sep 27, 1994;Build 7
  ;
 GRID(OUTCNT) ; from LR7OGMC
  N ACC,AGE,CDT,CMNT,DATA,DOC,FLAG,IDT,INTP,LINE,LRCW,LRX,MPLS,PLS,PORDER,PRNTCODE,RANGE,SEX,SPEC,SUB,TCNT,TESTNAME,TESTNUM
- N UNITS,VALUE,X,ZERO,INEXACT,DISPDATE
+ N UNITS,VALUE,X,ZERO
  ; the variables AGE, SEX, LRCW, and X are used withing the lab's print codes and ref ranges
  K ^TMP("LRMPLS",$J)
@@ -13,9 +13,7 @@
  I '$P(ZERO,U,3) Q
  S SPEC=+$P(ZERO,U,5)
- S INEXACT=$P(ZERO,U,2),DISPDATE=$S(INEXACT:CDT\1,1:CDT)
  S DOC=$$NAME^LR7OGMP(+$P(ZERO,U,10))
  S ACC=$P(ZERO,U,6)
  S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,4,6)=SPEC_U_$P($G(^LAB(61,SPEC,0)),U)_U_ACC_U_DOC
- S $P(^TMP("LR7OGX",$J,"OUTPUT",1),U,10)=DISPDATE
  S (TCNT,MPLS,PORDER,PLS)=0
  S PLS=$O(^TMP("LRPLS",$J,0))
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGMM.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OGMM.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGMM.m	(revision 636)
@@ -1,7 +1,7 @@
 LR7OGMM ;SLC/STAFF- Interim report rpc memo micro ;5/20/97  18:52
- ;;5.2;LAB SERVICE;**187,312,364**;Sep 27, 1994;Build 3
+ ;;5.2;LAB SERVICE;**187,312**;Sep 27, 1994
  ;
 MI(LRDFN,IDT,MICROSUB,ALL,OUTCNT,FORMAT,DONE) ; from LR7OGM
- N MISUB,OK,ZERO,INEXACT,DISPDATE,XDT
+ N MISUB,OK
  I '$D(^LR(LRDFN,"MI",IDT)) Q
  S OK=ALL
@@ -9,12 +9,5 @@
  I 'OK Q
  I $G(FORMAT) D
- .S XDT=9999999-IDT
- .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="^MI^"_XDT D
- ..; determine if collection time is "inexact" and put the 
- ..; collection day/time that is to be displayed in piece 10
- ..S ZERO=$G(^LR(LRDFN,"MI",IDT,0)) Q:ZERO=""
- ..S INEXACT=$P(ZERO,U,2)
- ..S DISPDATE=$S(INEXACT:XDT\1,1:XDT)
- ..S $P(^TMP("LR7OGX",$J,"OUTPUT",OUTCNT),U,10)=DISPDATE
+ .S ^TMP("LR7OGX",$J,"OUTPUT",OUTCNT)="^MI^"_(9999999-IDT)
  .S OUTCNT=OUTCNT+1
  .S DONE=1
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGMP.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OGMP.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OGMP.m	(revision 636)
@@ -1,4 +1,4 @@
-LR7OGMP ;DALOI/STAFF- Interim report rpc memo print ; Mar 10, 2003
- ;;5.2;LAB SERVICE;**187,246,282,286,344**;Sep 27, 1994
+LR7OGMP ;DALOI/STAFF- Interim report rpc memo print ;10/10/07  11:52
+ ;;5.2;LAB SERVICE;**187,246,282,286,344**;Sep 27, 1994;Build 2
  ;
 PRINT(OUTCNT) ; from LR7OGMC
@@ -27,5 +27,7 @@
  .. S TESTNUM=+DATA,PRNTCODE=$P(DATA,U,5),SUB=$P(DATA,U,6),FLAG=$P(DATA,U,8),X=$P(DATA,U,7),UNITS=$P(DATA,U,9),RANGE=$P(DATA,U,10),SITE=$P(DATA,U,11)
  .. S LOW=$P(RANGE,"-"),HIGH=$P(RANGE,"-",2),THER=$P(DATA,U,12)
- .. S LINE="     "_$S($L($P(DATA,U,2))>20:$P(DATA,U,3),1:$P(DATA,U,2))
+ .. ;S LINE="     "_$S($L($P(DATA,U,2))>20:$P(DATA,U,3),1:$P(DATA,U,2))
+ .. I $L($P(DATA,U,2))>28,$P(DATA,U,3)'="" S LINE=$P(DATA,U,3)
+ .. E  S LINE=$E($P(DATA,U,2),1,28)
  .. S LINE=$$SETSTR^VALM1("",LINE,28,0)
  .. I PRNTCODE="" S LINE=LINE_$J(X,8)
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OSUM1.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OSUM1.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OSUM1.m	(revision 636)
@@ -1,4 +1,4 @@
-LR7OSUM1 ;DALOI/dcm - Silent Patient cum cont. ; Mar 11, 2003
- ;;5.2;LAB SERVICE;**121,187,256,286**;Sep 27, 1994
+LR7OSUM1 ;DALOI/dcm - Silent Patient cum cont. ;10/10/07  11:51
+ ;;5.2;LAB SERVICE;**121,187,256,286**;Sep 27, 1994;Build 2
  ;
 LRIDT ; from LR7OSUM
@@ -90,5 +90,8 @@
  S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
  ;
- S X=$S($D(^LAB(60,LRTST,.1)):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^")),^TMP("LRT",$J,X)="MISCELLANEOUS TESTS"
+ ; S X=$S($D(^LAB(60,LRTST,.1)):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^")),^TMP("LRT",$J,X)="MISCELLANEOUS TESTS"
+ S TST=$P($G(^LAB(60,LRTST,.1)),"^")
+ I TST="" S TST=$P(^LAB(60,LRTST,0),"^")
+ S ^TMP("LRT",$J,TST)="MISCELLANEOUS TESTS"
  ;
  ; Grab specimen comments
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OSUM6.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OSUM6.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OSUM6.m	(revision 636)
@@ -1,4 +1,4 @@
-LR7OSUM6 ;DALOI/dcm - Silent Patient cum cont. ;Mar 11, 2003
- ;;5.2;LAB SERVICE;**121,201,187,286,356**;Sep 27, 1994;Build 8
+LR7OSUM6 ;DALOI/dcm - Silent Patient cum cont. ;10/10/07  19:26
+ ;;5.2;LAB SERVICE;**121,201,187,286,356**;Sep 27, 1994;Build 2
  ;
 LRUDT(X) ;Get output date/time
@@ -43,5 +43,8 @@
  S LRSPEM=$S($L(LRSPE):$P(^LAB(61,LRSPE,0),U,1),1:"")
  G:'LRTEST COMM
- S LRNAME=$P(^LAB(60,LRTEST,.1),U,1)
+ S LRNAME=$P(^LAB(60,LRTEST,0),"^")
+ I $L(LRNAME)>13,$P($G(^LAB(60,LRTEST,.1)),"^")'="" S LRNAME=$P(^LAB(60,LRTEST,.1),"^")
+ E  S LRNAME=$E(LRNAME,1,13)
+ ; S LRNAME=$P(^LAB(60,LRTEST,.1),U,1)
  ;S:$L(LRSPE)&($D(^LAB(60,LRTEST,1,LRSPE,0))) X=^(0),@("LRLO="_$S($L($P(X,U,2)):$P(X,U,2),1:"""""")),@("LRHI="_$S($L($P(X,U,3)):$P(X,U,3),1:"""""")),LRUNT=$P(X,U,7)
  ;
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OV0.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LR7OV0.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LR7OV0.m	(revision 636)
@@ -1,4 +1,4 @@
 LR7OV0 ;slc/dcm - Update orderable items ;8/11/97
- ;;5.2;LAB SERVICE;**121,187,357,361**;Sep 27, 1994
+ ;;5.2;LAB SERVICE;**121,187,357,361**;Sep 27, 1994;Build 2
  ;
 TEST(TEST,ICNT) ;Process single test
@@ -41,4 +41,5 @@
  Q MFI
 SINGLE(TEST,MFICODE,MFECODE) ;Message for a single test
+ L +LR7OV0(TEST)
  ;TEST= ptr to test in file 60
  ;MFICODE=File Level Event Code
@@ -50,4 +51,5 @@
  ;W !!,$P(^LAB(60,TEST,0),"^"),! I $D(ORUPDMSG(3)) ZW ORUPDMSG
  I $D(ORUPDMSG(3)) S ORUPDMSG="ORUPDMSG" D MSG^XQOR("LR7O ORDERABLE OR",.ORUPDMSG) ;Send update message
+ L -LR7OV0(TEST)
  Q
 ADD(TEST) ;Add single record to Master file
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRAPBR1.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRAPBR1.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRAPBR1.m	(revision 636)
@@ -1,4 +1,4 @@
 LRAPBR1 ;DALOI/WTY/KLL;AP Browser Print Cont.;11/08/01
- ;;5.2;LAB SERVICE;**259,317,363**;Sep 27, 1994;Build 3
+ ;;5.2;LAB SERVICE;**259,317**;Sep 27, 1994
  ;
  ;
@@ -101,5 +101,4 @@
  .S X=$T(FIELDS+LRCNT)
  .S LRV=$P(X,";",2),LRV1=$P(X,";",3),LRV2=$P(X,";",4)
- .D TEXTCHK
  .I $P($G(^LR(LRDFN,LRSS,LRI,LRV,0)),U,4) D
  ..D GLENTRY("","",1),GLENTRY(LR(69.2,LRV1),"",1)
@@ -252,15 +251,2 @@
  ;1.1;.04;4
  ;1.4;.14;5
-TEXTCHK ; update text line counter if it is missing (Remedy 116253)
- N I,X,DATA
- S I=0
- K ^TMP("WP",$J)
- S X=$G(^LR(LRDFN,LRSS,LRI,LRV,0))
- I X'="",$L(X,"^")=1 D
- . F  S I=$O(^LR(LRDFN,LRSS,LRI,LRV,I)) Q:I=""  D
- . . S DATA=$G(^LR(LRDFN,LRSS,LRI,LRV,I,0))
- . . S ^TMP("WP",$J,I,0)=DATA
- I $D(^TMP("WP",$J)) D
- . D WP^DIE(63.08,LRI_","_LRDFN_",",LRV,"","^TMP(""WP"",$J)")
- . K ^TMP("WP",$J)
- Q
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRSPT.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRSPT.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRSPT.m	(revision 636)
@@ -1,4 +1,4 @@
 LRSPT ;AVAMC/REG/WTY - AP PRELIMINARY REPORTS ;10/16/01
- ;;5.2;LAB SERVICE;**1,72,248,259,373**;Sep 27, 1994;Build 1
+ ;;5.2;LAB SERVICE;**1,72,248,259**;Sep 27, 1994
  ;
  ;Reference to ^%DT supported by IA #10003
@@ -67,5 +67,5 @@
  K ^UTILITY($J) S DIWR=IOM-5,DIWF="W",LR("A")=0
  W ! F LRZ=0:1 S LR("A")=$O(^LRO(69.2,LRAA,10,LR("A"))) Q:'LR("A")  D
- .D:$Y>(IOSL-13) F^LRAPF,H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP
+ .D:$Y>(IOSL-6) H S X=^LRO(69.2,LRAA,10,LR("A"),0) D ^DIWP
  D:LRZ ^DIWW
  S LRO=1 D F^LRAPF
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRSRVR6.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRSRVR6.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRSRVR6.m	(revision 636)
@@ -1,4 +1,4 @@
 LRSRVR6 ;DALIO/JMC - LAB DATA SERVER CONT'D SNOMED EXTRACT ;Aug 17, 2006
- ;;5.2;LAB SERVICE;**346,378**;Sep 27, 1994;Build 1
+ ;;5.2;LAB SERVICE;**346**;Sep 27, 1994;Build 10
  ; Produces SNOMED extract via LRLABSERVER option
  ;
@@ -119,5 +119,4 @@
  S LRINSTR("ADDR FLAGS")="R"
  S LRINSTR("FROM")="LAB_PACKAGE"
- S LRMSUBJ=$E(LRMSUBJ,1,65)
  D SENDMSG^XMXAPI(.5,LRMSUBJ,"^TMP($J,""LRDATA"")",.LRTO,.LRINSTR,.LRTASK)
  Q
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRVER3A.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVER3A.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRVER3A.m	(revision 636)
@@ -1,4 +1,4 @@
 LRVER3A ;SLC/CJS/DALOI/FHS - DATA VERIFICATION ;5/27/03  14:49
- ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295,373**;Sep 27, 1994;Build 1
+ ;;5.2;LAB SERVICE;**1,5,42,100,121,153,190,221,254,263,266,274,295**;Sep 27, 1994
  ;Also contains LRORFLG to restrict multiple OERR alerts (VER+2)
  ; Reference to ^DIC(42 supported by IA #10039
@@ -12,5 +12,5 @@
  S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3)),(LRAOD,LRACD)=$P(^(0),U,3)
  S LRACD=$S($D(^LRO(68,LRAA,1,LRAD,1,LRAN,9)):^(9),1:LRACD)
- S:'($D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2) LRACD=LRAD
+ S:'$D(^LRO(68,LRAA,1,LRACD,1,LRAN,0))#2 LRACD=LRAD
  S LRAOD=$S($D(^LRO(68,LRAA,1,LRAOD,1,LRAN,0))#2:LRAOD,1:LRAD)
  I '$G(LRFIX) S LRNOW=$$NOW^XLFDT,$P(^LR(LRDFN,LRSS,LRIDT,0),U,3,4)=LRNOW_U_$S($G(LRDUZ):LRDUZ,1:DUZ)
@@ -38,5 +38,5 @@
  ;-I $P(^LR(LRDFN,0),U,2)=2 I '$D(ZZCARE) S ZRECORD=0,ZRECORD=$O(^SC("C",LRLLOC,ZRECORD)) I ZRECORD'="",$D(^LRTXFCS(5000024,1,618001,"B",ZRECORD)) D FCS  ; CJS/MPLS 3-16-92 LINE ADDED TO CHECK IF REQUESTING LOCATION IS CAREVUE SUPPORTED  ++RG
  S D1=1,X=0 F  S X=$O(^TMP("LR",$J,"TMP",X)) Q:X<1  S LRT=+^(X) I $D(LRM(X)) D REQ
- I $D(^LRO(69,LRODT,1,LRSN,0)) S ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW
+ S:$D(^LRO(69,LRODT,1,LRSN,0)) ^(3)=$S($D(^(3)):+^(3),1:LRNOW) S:'$P(^(3),U,2) $P(^(3),U,2)=LRNOW
  I D1,'$D(A2) S:'$P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) $P(^(3),U,4)=LRNOW,^LRO(68,LRAA,1,LRAD,1,"AC",LRNOW,LRAN)=""
  ; Class I CareVue routine TASKED if CareVue ward - pwc/10-2000
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRVER4.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRVER4.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRVER4.m	(revision 636)
@@ -1,3 +1,3 @@
-LRVER4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;8/11/97
+LRVER4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ; 7/28/05 3:08pm
  ;;5.2;LAB SERVICE;**14,42,112,121,140,171,153,188,279,283,286**;Sep 27, 1994
  ;
@@ -10,5 +10,6 @@
  . W !!,PNM,"  SSN: ",SSN,"   " S LRLCT=LRLCT+1
  . I LRDPF=2 W "   LOC: ",$S(LRWRD'="":LRWRD,1:$S($L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)):$P(^(0),U,7),1:"??"))
- ;
+ ; VOE Fix for an error ;RED; 7/28/05
+ I $G(SEX)="" S SEX=""
  W !,"Pat Info: ",$P($G(^LR(LRDFN,.091)),U)
  W ?34," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRWLST1.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRWLST1.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRWLST1.m	(revision 636)
@@ -1,4 +1,4 @@
 LRWLST1 ;DALOI/CJS/RWF/FHS - ACCESSION SETUP ; July 19, 2006
- ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331,379**;Sep 27, 1994;Build 2
+ ;;5.2;LAB SERVICE;**48,65,121,153,261,286,331**;Sep 27, 1994;Build 7
  ;
  ; Reference to ^DIC(42 supported by IA #10039
@@ -99,15 +99,5 @@
  . S FDA(2,68.05,"+1,"_LR6802,.01)=LRSPEC
  . S FDA(2,68.05,"+1,"_LR6802,1)=$P(LRSAMP,";",1)
- . ;
- . ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
- . N LRLOCKOK,LRLOOPCT
- . S LRLOCKOK=0
- . F LRLOOPCT=1:1:10 Q:LRLOCKOK  D  I 'LRLOCKOK H 5
- . . K LRDIE(2)
- . . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
- . . S:$D(LRDIE(2))=0 LRLOCKOK=1
- . K LRLOCKOK,LRLOOPCT
- . ;
- . ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+ . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
  . I $D(LRDIE(2)) D MAILALRT
  ;
@@ -287,15 +277,5 @@
  S FDAIEN(1)=LRAN
  S FDA(2,68.02,"+1,"_LR6802,.01)=LRDFN
- ;
- ; Modification to prevent lock failures - loop 10 times to give system a chance to get lock
- N LRLOCKOK,LRLOOPCT
- S LRLOCKOK=0
- F LRLOOPCT=1:1:10 Q:LRLOCKOK  D  I 'LRLOCKOK H 5
- . K LRDIE(2)
- . D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
- . S:$D(LRDIE(2))=0 LRLOCKOK=1
- K LRLOCKOK,LRLOOPCT
- ;
- ;D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
+ D UPDATE^DIE("","FDA(2)","FDAIEN","LRDIE(2)")
  I $D(LRDIE(2)) D MAILALRT
  Q
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRWLST11.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRWLST11.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRWLST11.m	(revision 636)
@@ -1,4 +1,4 @@
 LRWLST11 ;DALOI/CJS,RWF/FHS - ACCESSION SETUP ;July 19, 2006
- ;;5.2;LAB SERVICE;**121,128,153,202,286,331,375**;Sep 27, 1994;Build 3
+ ;;5.2;LAB SERVICE;**121,128,153,202,286,331**;Sep 27, 1994;Build 7
  ;
 ST21 ;
@@ -12,5 +12,5 @@
  ; when tests are acessioned to the 'in common' area.
  I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D
- . I 'LRUNQ,$D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q
+ . I $D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q
  . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))
  . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y
Index: FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRX.m
===================================================================
--- FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRX.m	(revision 631)
+++ FOIAVistA/tag/r/LAB_SERVICE-LR-LS/LRX.m	(revision 636)
@@ -1,4 +1,4 @@
-LRX ;SLC/BA/DALISC/FHS - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;2/8/91  07:30
- ;;5.2;LAB SERVICE;**65,153,201,217,290,360**;Sep 27, 1994;Build 1
+LRX ;SLC/BA/DALISC/FHS - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;1/26/07  18:36
+ ;;5.2;LAB SERVICE;**65,153,201,217,290,360,350**;Sep 27, 1994;Build 10
 PT ;patient info
  ;
@@ -23,5 +23,6 @@
  . . S SEX=$P(VADM(5),U),DOB=$P(VADM(3),U),DOD=$P(VADM(6),U)
  . . S AGE=VADM(4),AGE(2)=$$AGE2(DOB,$G(LRCDT))
- . . S SSN=$P(VADM(2),U),LRWRD=$P(VAIN(4),U,2)
+ . . ; S SSN=$P(VADM(2),U),LRWRD=$P(VAIN(4),U,2)
+ . . S SSN=VA("PID"),LRWRD=$P(VAIN(4),U,2) ; for VOE
  . . S LRWRD(1)=+VAIN(4),LRRB=VAIN(5),LRPRAC=+VAIN(2)
  . . S:VAIN(3) LRTREA=+VAIN(3)
@@ -43,5 +44,6 @@
  . D DEM^VADPT D:'VAERR
  . . S PNM=VADM(1),SEX=$P(VADM(5),U)
- . . S DOB=$P(VADM(3),U),SSN=$P(VADM(2),U)
+ . . ; S DOB=$P(VADM(3),U),SSN=$P(VADM(2),U)
+ . . S DOB=$P(VADM(3),U),SSN=VA("PID") ; for VOE
  . . S AGE=VADM(4),AGE(2)=$$AGE2(DOB,$G(LRCDT))
  D SSNFM^LRU
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/GMPTSET.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/GMPTSET.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/GMPTSET.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPTSET ; ISL Setup Appl/User Defaults for Look-up ; 10-25-96
- ;;2.0;LEXICON UTILITY;**2**;Aug 15, 1996
+ ;;2.0;LEXICON UTILITY;**2**;Aug 15, 1996;Build 1
  ;
  ; Replaces Clinical Lexicon Utility v 1.0 GMPTSET and re-directs
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/GMPTU.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/GMPTU.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/GMPTU.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPTU ; ISL Miscellaneous Lexicon Utilities      ; 10-25-96
- ;;2.0;LEXICON UTILITY;**2**;Aug 15, 1996
+ ;;2.0;LEXICON UTILITY;**2**;Aug 15, 1996;Build 1
  ;
  ; Replaces Clinical Lexicon Utility v 1.0 GMPTU and re-directs
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2040.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2040.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2040.m	(revision 636)
@@ -1,4 +1,4 @@
 LEX2040 ; ISL/KER - Environment Check/Pre/Post Install ; 04/06/2006
- ;;2.0;LEXICON UTILITY;**40**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**40**;Sep 23, 1996;Build 1
  ;                     
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2040P.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2040P.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2040P.m	(revision 636)
@@ -1,4 +1,4 @@
 LEX2040P ; ISL/KER - Pre/Post Install ; 04/06/2006
- ;;2.0;LEXICON UTILITY;**40**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**40**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2042.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2042.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2042.m	(revision 636)
@@ -1,4 +1,4 @@
 LEX2042 ; ISL/KER - Environment Check/Pre/Post Install ; 04/06/2006
- ;;2.0;LEXICON UTILITY;**42**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**42**;Sep 23, 1996;Build 1
  ;                     
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2042P.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2042P.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2042P.m	(revision 636)
@@ -1,4 +1,4 @@
 LEX2042P ; ISL/KER - Pre/Post Install ; 07/01/2006
- ;;2.0;LEXICON UTILITY;**42**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**42**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2045.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2045.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2045.m	(revision 636)
@@ -1,4 +1,4 @@
 LEX2045 ; ISL/KER - Environment Check/Pre/Post Install ; 09/13/2006
- ;;2.0;LEXICON UTILITY;**45**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**45**;Sep 23, 1996;Build 1
  ;                     
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2045P.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEX2045P.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEX2045P.m	(revision 636)
@@ -1,4 +1,4 @@
 LEX2045P ; ISL/KER - Pre/Post Install ; 09/13/2006
- ;;2.0;LEXICON UTILITY;**45**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**45**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXA ; ISA/FJF/KER-Look-up (Silent) ; 09/06/2006
- ;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43**;Sep 23, 1996;Build 24
+ ;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA1.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA1.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA1.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXA1 ; ISA/CJE-Lexicon Look-up (Loud) ; 02/02/2006
- ;;2.0;LEXICON UTILITY;**3,4,6,11,15,38**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**3,4,6,11,15,38**;Sep 23, 1996;Build 1
  ; CJE; Force quit when user enters '^' at search prompt.
  ; JPK; Display code attached to a selected term
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXA2 ;ISL/KER-Look-up (Loud) Select ; 02/02/2006
- ;;2.0;LEXICON UTILITY;**38**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**38**;Sep 23, 1996;Build 1
  ;
 SELECT ; Select from List
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXA3 ; ISL Look-up (Loud) Functions             ; 01-13-97
- ;;2.0;LEXICON UTILITY;**1,4**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**1,4**;Sep 23, 1996;Build 1
  ;
 DH ; Display Help                 LEX("HLP")
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXA4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXA4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXA4 ;ISA/CJE-Look-up (Loud) Unresolved Narrative ;01-13-00
- ;;2.0;LEXICON UTILITY;**3,6,15**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**3,6,15**;Sep 23, 1996;Build 1
  ; JPK;Added more explanatory help text for display
  ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAB.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAB.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAB.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAB ; ISL/KER Look-up Exact Match "B" index ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXABC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXABC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXABC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXABC ; ISL/KER - Look-up by Code ; 02/02/2006
- ;;2.0;LEXICON UTILITY;**4,25,26,29,38**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4,25,26,29,38**;Sep 23, 1996;Build 1
  ;
  ; S X=$$EN^LEXABC(CODE,LEXVDT)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXABC2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXABC2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXABC2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXABC2 ; ISL Look-up by Code (part 2)             ; 01-25-97
- ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
  ;
 REO ; Reorder list
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAFIL.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAFIL.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAFIL.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAFIL ; ISL Lookup Filter                        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; S LEXFILR=$$EN^LEXAFIL(LEXFIL,LEXE)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAL.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAL.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAL.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAL ; ISL Look-up List (Global)                ; 10-15-97
- ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
  ;
  ; Add to the list
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAL2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAL2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAL2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAL2 ; ISL Look-up List (Array)                 ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ;  LEXL        Last on List
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXALK.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXALK.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXALK.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXALK ; ISL/KER Look-up by Words ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**2,3,6,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**2,3,6,25**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAM.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAM.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAM.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAM ; ISL Look-up Misc (Setup/Parse)           ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SETUP(LEXSUB) ; Set up search variables
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAMD ; ISL/KER Look-up Modifiers ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**6,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6,25**;Sep 23, 1996;Build 1
  ;
  ; LEXX     IEN file 757.01 of an expression w/Modifiers
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAMD2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAMD2 ; ISL Look-up Check Modifiers              ; 10-15-97
- ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
  Q
 CHKMOD ; Check Modifiers
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR ;ISA/FJF/KER-Look-up (Interpret User Response) ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**3,19,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**3,19,25**;Sep 23, 1996;Build 1
  ;
  ; User Responses
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR2 ; ISL Look-up Response (up arrow/jump/null); 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 UPA(LEXUR) ; Up-Arrow Detected
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR3 ; ISL Look-up Response (Help, Def, MAX)    ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 HLP ; Help
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR4 ; ISL/KER Look-up Response (Select Entry) ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**4,5,6,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4,5,6,25**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR5.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR5.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR5.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR5 ; ISL/KER - Look-up Response (Select Entry) ; 02/02/2006
- ;;2.0;LEXICON UTILITY;**14,25,26,38**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**14,25,26,38**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR6.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR6.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR6.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR6 ; ISL Look-up Response (Unresolved Narr)   ; 05/25/1998
- ;;2.0;LEXICON UTILITY;**3,9,11**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**3,9,11**;Sep 23, 1996;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR7.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAR7.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAR7.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAR7 ; ISL Look-up Response (MAIL)              ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**9,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**9,25**;Sep 23, 1996;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAS ; ISL Look-up Check Input                  ; 09-23-96
- ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
  ;
 SPL(LEXX) ; Check word
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAS2 ; ISL Look-up Check Input (ONE)            ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 ONE(LEXX) ; One letter missing/incorrect
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAS3 ; ISL Look-up Check Input (SHIFT)          ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SHIFT(LEXX) ; Letters are shifted out of position
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAS4 ; ISL Look-up Check Input (DBL,REM)        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 DBL(LEXX) ; Excessive Double Characters
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS5.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS5.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS5.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAS5 ; ISL Look-up Check Input (SPLIT)          ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS6.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS6.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS6.m	(revision 636)
@@ -1,4 +1,4 @@
-LEXAS6 ; ISL/FJF Look-up Check Input (TRIM,EXP,TP,SCH); 12/07/2006
- ;;2.0;LEXICON UTILITY;**41**;Sep 23, 1996;Build 34
+LEXAS6 ; ISL Look-up Check Input (TRIM,EXP,TP,SCH); 09-23-96
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 TRIM(LEXX) ; Trim string
@@ -47,5 +47,5 @@
  . F  S LEXCK=$O(^LEX(757.01,"ASL",LEXCK)) Q:LEXCK=""!('LEXOKL)  D
  . . I $E(LEXCK,LEXI)'="",$E(LEXCK,LEXI)'=LEXLTR S LEXOKL=0 Q
- . . I LEXCK'[LEXC,$E(LEXCK,LEXI)'=LEXLTR S LEXCK="~~~~~~~~~~~" Q
+ . . I LEXCK'[LEXC,$E(LEXCK,LEXI)'=LEXLTR S LEXCK="ZZZZ" Q
  . S:LEXOKL LEXF=LEXF_LEXLTR S:'LEXOKL LEXOK=1
  . S:$D(^LEX(757.01,"AWRD",LEXF)) LEXOK=1
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS7.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXAS7.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXAS7.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXAS7 ; ISL Look-up Check Input (LC,TC)          ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 LC(LEXX) ; Leading characters
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXASC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXASC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXASC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXASC ; ISL/KER Look-up by Shortcuts ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;
  ; ^TMP("LEXFND",$J)  Entries found
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXASO.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXASO.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXASO.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXASO ; ISL/KER Look-up Display String (Sources) ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25,32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25,32**;Sep 23, 1996;Build 1
  ;
  ; Entry S X=$$SO^LEXASO(IEN,SAB,ALL,DATE)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXCODE.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXCODE.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXCODE.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXCODE ; ISL/KER Retrieval of IEN^Term based on Code ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDCC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDCC ; ISL Default Display                      ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  D EN^LEXDCC             LEXAP is unknown
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCCC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDCCC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCCC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDCCC ; ISL Default Display - Create             ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDCCC
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCCS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDCCS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCCS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDCCS ; ISL Default Display - Select             ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Special Look-up in file 757.31 Display formats
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCX.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDCX.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCX.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDCX ; ISL Default Shortcut Context             ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  D EN^LEXDCX              LEXAP is unknown
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCXS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDCXS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDCXS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDCXS ; ISL Default Context - Select             ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Special Look-up in file 757.41 Shortcut Context
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD1.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDD1.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD1.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDD1 ; ISL Display Defaults                     ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SHOW ; Show user defaults
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDD2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDD2 ; ISL Display Defaults - Build List        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 BUILD ; Display defaults
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDD3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDD3 ; ISL Display Defaults - Display List      ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 DSPLY ; Display Defaults contained in LEXD(
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDD4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDD4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDD4 ; ISL Display Defaults - List Elements     ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Create the Display for a user
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDS ; ISL Display Defaults - Single User       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  D EN^LEXDDS              LEXAP is unknown
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSD.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSD.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSD.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDSD ; ISL Display Defaults - Single User Disp  ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 LEXSHOW ; Translate LEXSHOW
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSP.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSP.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSP.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDSP ; ISL Display Defaults - Single User Parse ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDSS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDSS ; ISL Display Defaults - Single User Save  ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Saves default elements into the local array LEX
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDT1.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDT1.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDT1.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDT1 ; ISL Display Defaults - Translate String  ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EN ; String Type
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDT2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDT2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDT2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDT2 ; ISL Display Defaults - Concatenate Text  ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 CONCAT ; Concatenation of Data Elements
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDTC ; ISL Display Defaults - Shortcut Context  ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 CON ; Shortcut Context
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTD.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTD.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTD.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDTD ; ISL Display Defaults - Display           ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 DSO ; Display Sources
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTF.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTF.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTF.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDTF ; ISL Display Defaults - Filter            ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SC ; Filter by Semantic Classifications
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTV.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTV.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDDTV.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDDTV ; ISL Display Defaults - Vocabulary        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SUB ; Select between Logical and Physical Subsets
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFL.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFL.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFL.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFL ; ISL Default Filter                       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  D EN^LEXDFL             LEXAP is unknown
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFLC ; ISL Default Filter - Create              ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDFLC
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFLS ; ISL Default Filter - Select              ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Special Look-up in file 757.3 Screens
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLT.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLT.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFLT.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFLT ; ISL Default Filter - Filter Type         ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDFLT
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFN ; ISL Default Names                        ; 10-15-97
- ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
  ;
 APPN(X) ; Application Name
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFN2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFN2 ; ISL Default Names                        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 AP(X) ; Application Pointer
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSB.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSB.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSB.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFSB ; ISL Default Filter - Include/Exclude     ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDFSB
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSE.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSE.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSE.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFSE ; ISL Default Filter - Exclude Semantics   ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Called from LEXDFSI (set the EXCLUDE string)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSI.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSI.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSI.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFSI ; ISL Default Filter - Include Semantics   ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSO.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSO.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSO.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFSO ; ISL Default Filter - Sources             ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDFSO
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFSS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFSS ; ISL Default Filter - Semantics/Sources   ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDFSS
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFST.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDFST.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDFST.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDFST ; ISL Default Filter - Semantic Types      ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDFST
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDM.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDM ; ISL Default Misc - Mod/Del Sel/Create    ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$MOD^LEXDM(X)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDM2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDM2 ; ISL Default Misc - Ask to delete         ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  S X=$$EN^LEXDM2(USER,AP,DEF)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDM3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDM3 ; ISL Default Misc - Name Default          ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; LEXFIL    Flag for Filter v.s. Display
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDM4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDM4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDM4 ; ISL Default Misc - Files/User/Svc/Loc    ; 02-02-96
- ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
  ;
 DFI(LEXX) ; Select one application
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMG.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDMG.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMG.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDMG ; ISL Defaults - Manager Options           ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; LEXDICS     Filter
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGO.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGO.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGO.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDMGO ; ISL Defaults - Manager/Overwrite         ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; LEXOVER     Flag - Overwrite user defaults (Y/N)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGT.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGT.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGT.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDMGT ; ISL Defaults - Manager/Update            ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
  ; LEXDICS     Filter
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGU.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGU.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGU.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDMGU ; ISL Defaults - Manager/User Group        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; LEXDICS(0)  Filter name
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGV.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGV.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDMGV.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDMGV ; ISL Defaults - Manager/Verify            ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; LEXDICS     Filter
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDSV.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDSV.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDSV.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDSV ; ISL Defaults - Save                      ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
  ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDVO.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDVO.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDVO.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDVO ; ISL Default Vocabulary                   ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Entry:  D EN^LEXDVO              LEXAP is unknown
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDVOS.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXDVOS.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXDVOS.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXDVOS ; ISL Default Vocabulary - Select          ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Special Look-up in file 757.2 Subset Definitions
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXEDF1.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXEDF1.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXEDF1.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXEDF1 ; ISL Edit/Display a Definition (Part 1)   ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**3,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**3,25**;Sep 23, 1996;Build 1
  ;
  N DIC,DIE,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,DA,X,Y
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXEDF2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXEDF2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXEDF2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXEDF2 ; ISL Edit/Display a Definition (Part 2)   ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EXP(LEXX) ; Select an expression
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXERF.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXERF.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXERF.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXERF ; ISL Functions for Exc/Rep Words          ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EXIST(X) ; Boolean function returns:
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXERI.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXERI.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXERI.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXERI ; ISL Exc/Rep Word Input Transformations   ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
  ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXHLP.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXHLP.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXHLP.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXHLP ; ISL Help/input transformations              ; 05/25/1998
- ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996;Build 1
  ;
 EXC ; Excluded Word Help
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXIENV.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXIENV.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXIENV.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXIENV ; ISL Environment Check                    ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EN N Y
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILG.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXILG.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILG.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXILG ; ISL Env/Post for ^LEX and ^GMP           ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
 PRE ; Pre-Init
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGD.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXILGD.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGD.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXILGD ; ISL Delete Lexicon v 1.0                 ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
 DD ; Remove Lexicon Version 1.0 Files (DD only)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGO.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXILGO.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGO.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXILGO ; ISL Rename Options                       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
 RE ; Entry point to rename GMPT Options to LEX namespace
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGP.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXILGP.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGP.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXILGP ; ISL Save/Restore Pointers                ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
 SP ; Save "Pointed to by"
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGU.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXILGU.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGU.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXILGU ; ISL Save/Restore User Defaults           ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
 SD ; Save User Defaults from ^GMPT
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGX.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXILGX.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXILGX.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXILGX ; ISL Delete GMP from XTLK                 ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  Q
 EN ; Remove Clinical Lexicon Utility v 1.0 from the XT
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXLGM ; ISL Lexicon Survey (Post Inst/Oper)     ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;
 EN ; Operational Task
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXLGM2 ; ISL Lexicon Survey (GBL/DEF/XT/OPT/RTN) ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLGM3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXLGM3 ; ISL Lexicon Survey (Terms in PL)        ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  Q
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLK.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLK.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLK.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXLK ; ISL Demo Look Up                         ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EN ; Initialize variables
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLK2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXLK2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXLK2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXLK2 ;ISL/FJF-Look Up - Expression Attributes ;09-10-01
- ;;2.0;LEXICON UTILITY;**6,19**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6,19**;Sep 23, 1996;Build 1
  ;
 GET(Y) ; Build list in array LEX
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXMTLU.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXMTLU.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXMTLU.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXMTLU ; ISL Setup Appl/User Defaults for Look-up ; 05/25/1998
- ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996;Build 1
  ;
 EN ; X not set
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX1.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX1.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX1.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX1 ; ISL Set/kill indexes (Part 1)            ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 S ; Set Expression file (#757.01) word index node AWRD
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX2 ; ISL Set/kill indexes (Part 2)            ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SS ; Get (unique) text for an expression in the Subset file
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX3 ; ISL Set/kill indexes (Part 3) Link       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 S ; Set indexes for file 757.05
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX4 ; ISL Set/kill indexes (Part 4) Link       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 LINK ; Link a Keyword to an expression
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX5.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX5.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX5.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX5 ; ISL Set/kill indexes (Part 5) Link       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EXCL ; Is a term used with an "Exclusive" meaning?
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX6.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX6.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX6.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX6 ; ISL Set/kill indexes (Misc)              ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 SRA ; Set Shortcut index
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX8.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX8.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXNDX8.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXNDX8 ; ISL/KER/FJF Set/kill indexes 757.02 ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;                    
  ; Set and Kill Activation History
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPL.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPL.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPL.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXPL ; ISL Problem List Survey                 ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;
  ; Entry Points
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLEM.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPLEM.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLEM.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXPLEM ; ISL Problem List Exact Match URs           ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Fixes unresolved narratives which have an exact match in the
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLIA.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPLIA.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLIA.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXPLIA ; ISL Problem List In-Active ICD Codes       ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Fixes ICD pointers in the Problem List to In-Active ICD Codes
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLUP.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPLUP.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPLUP.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXPLUP ; ISL Problem List Update 799.9              ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
  ; Fixes ICD code 799.9 for Problems which have a Lexicon pointer
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPRNT.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXPRNT.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXPRNT.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXPRNT ; ISL Print Utilities for the Lexicon      ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 XTLK ; XTLK  Display format for MTLU 
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSC ; ISL Shortcuts Add/Delete                 ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 EN N LEXCX,LEXCXN,LEXDICS,LEXEDIT,LEXRP,LEXE
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSC2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSC2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSC2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSC2 ; ISL Shortcuts Add/Delete                 ; 05/25/1998
- ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**11**;Sep 23, 1996;Build 1
  ;
 WRT(LEXSTR) ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSC3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSC3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSC3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSC3 ; ISL Shortcuts Add/Delete                 ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 ADD ; Add a shortcut
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSET.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSET ; ISL/KER Setup Appl/User Defaults for Look-up ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSET2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSET2 ; ISL Retrieve Appl/Sub/Mode/User Defaults ; 10-15-97
- ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
  ;
 APP(LEXA) ; Application
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSET3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSET3 ; ISL Overwrite/Merge Appl/User Defaults   ; 10-15-97
- ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
  ;
 OVER ;
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSET4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSET4 ; ISL Setup Functions                      ; 09-23-96
- ;;2.0;LEXICON UTILITY;;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;;Sep 23, 1996;Build 1
  ;
 NS(LEX) ; Look-up application namespace
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET5.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSET5.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSET5.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSET5 ; ISL Setup Appl/User Defaults for Look-up ; 05/25/1998
- ;;2.0;LEXICON UTILITY;**6,11**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**6,11**;Sep 23, 1996;Build 1
  ;
 EN ; Set variables
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSRC ; ISL/KER - Classification Code Source ; 02/02/2006
- ;;2.0;LEXICON UTILITY;**7,25,26,38**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**7,25,26,38**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXSRC2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXSRC2 ; ISL/KER/FJF Classification Code Source Util ; 01/01/2004
- ;;2.0;LEXICON UTILITY;**25,28**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**25,28**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXTOLKN.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXTOLKN.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXTOLKN.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXTOLKN ; ISL Parse term into words                ; 01-31-97
- ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4**;Sep 23, 1996;Build 1
  ;
  ; Returns ^TMP("LEXTKN",$J,#,WORD) containing words
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXU.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXU.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXU.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXU ; ISA/FJF-Miscellaneous Lexicon Utilities; 06/23/2005
- ;;2.0;LEXICON UTILITY;**2,6,9,15,25,36**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**2,6,9,15,25,36**;Sep 23, 1996;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI.m	(revision 636)
@@ -1,12 +1,12 @@
-LEXXFI ; ISL/KER - File Info                     ; 04/22/2008
- ;;2.0;LEXICON UTILITY;**32,46,49,41**;Sep 23, 1996;Build 34
+LEXXFI ; ISL/KER - File Info                     ; 02/22/2007
+ ;;2.0;LEXICON UTILITY;**32,46,49**;Sep 23, 1996;Build 3
  Q
- ;
+ ;                   
  ; Global Variables
  ;   ^LEXM(0
- ;   ^TMP("LEX*",$J    SACC 2.3.2.5.1
- ;
+ ;   ^TMP("LEX*",$J    SACC 2.3.2.5.1  
+ ;             
  ; External References
- ;   DBIA 10086  HOME^%ZIS
+ ;   DBIA 10086  HOME^%ZIS           
  ;   DBIA 10089  ^%ZISC
  ;   DBIA 10063  ^%ZTLOAD
@@ -17,5 +17,5 @@
  ;   DBIA 10070  ^XMD
  ;   DBIA  4409  $$DTIME^XUP
- ;
+ ;             
  ; Newed by Post-Install LEX20nnP
  ;   LEXBUILD  Build
@@ -25,14 +25,11 @@
  ;   LEXREQP   Required Patches
  ;   LEXSHORT  Flag for Summary Install Message
- ;
+ ;                
  ; XPDA        Newed by KIDS during Install
  ; LEXCOUNT    Flag Checked $D() and not used
- ;
+ ;             
  ; Checksums/Counts
 EN ;   For One or More File(s)
- N LEXENV,LEXMET,LEXID
- S LEXENV=$$ENV
- Q:+LEXENV'>0
- S LEXMET=$$MT^LEXXFI7
+ N LEXENV,LEXMET,LEXID S LEXENV=$$ENV Q:+LEXENV'>0  S LEXMET=$$MT^LEXXFI7
  I '$L(LEXMET) W !!," Checksum Files (One or All) not Selected" Q
  I $L($T(@(LEXMET_"^LEXXFI")))>0 W ! D @LEXMET
@@ -46,6 +43,5 @@
  S LEXLDR=$$LDR^LEXXFI8(LEXFI),LEXMOD=LEXMOD+($$MOD^LEXXFI8(LEXFI))
  S LEXNM=$$FN^LEXXFI8(LEXFI),LEXTT=" "
- W !
- D ONE^LEXXFI2(LEXFI),ONE^LEXXFI3(LEXFI),ONE^LEXXFI5(LEXFI)
+ W ! D ONE^LEXXFI2(LEXFI),ONE^LEXXFI3(LEXFI),ONE^LEXXFI5(LEXFI)
  S LEXEND=$$TIC^LEXXFI8,LEXELP=$$ELAP^LEXXFI8(LEXBEG,LEXEND)
  S:LEXELP="" LEXELP="00:00:00"
@@ -69,49 +65,32 @@
  D KILL
  Q
- ;
+ ;              
 POST ; Entry Point for Post-Install Message
  N LEXPOST S LEXPOST=""
- ;
+ ;            
 SEND ; Send Message
  N LEXDESC,LEXENV,LEXP,LEXACCT,LEXPRO,LEXPRON,LEXSEND,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZTQUEUED,ZTREQ
- S LEXP=0,LEXENV=$$ENV
- Q:+LEXENV'>0
- S LEXSEND="",LEXPRON="LEXICAL SERVICES UPDATE",LEXPRO=$G(^LEXM(0,"PRO"))
- S:+LEXPRO>0 LEXPRO=$$FMTE^XLFDT(LEXPRO,"1"),LEXP=1
- S LEXACCT=$$U^LEXXFI7 S ZTSAVE("LEXACCT")=""
- S ZTRTN="ALL^LEXXFI",ZTSAVE("LEXSEND")="",ZTSAVE("LEXPOST")=""
- S:$D(LEXCOUNT) ZTSAVE("LEXCOUNT")=""
- I $L($G(LEXPRO)),$L($G(LEXPRON)),+$G(LEXP)>0 S ZTSAVE("LEXPRO")="",ZTSAVE("LEXPRON")=""
- S:$D(LEXLREV) ZTSAVE("LEXLREV")=""
- S:$D(LEXREQP) ZTSAVE("LEXREQP")=""
- S:$D(LEXBUILD) ZTSAVE("LEXBUILD")=""
- S:$D(LEXSHORT) ZTSAVE("LEXSHORT")=""
- S:$D(LEXIGHF) ZTSAVE("LEXIGHF")=""
- S:$D(LEXCRE) ZTSAVE("LEXCRE")=""
- S:$D(LEXID) ZTSAVE("LEXID")=""
- S:$D(XPDA) ZTSAVE("XPDA")=""
- S (LEXDESC,ZTDESC)="Post-Install File Counts "
- S:$D(LEXSHORT) (LEXDESC,ZTDESC)="Post-Install Summary"
- S ZTDTH=$H
- S ZTIO=""
- D ^%ZTLOAD
- W:+($G(ZTSK))>0 !!,"  ",LEXDESC,!,"  Queued Task #",+($G(ZTSK)) W !
- D ^%ZISC
+ S LEXP=0,LEXENV=$$ENV Q:+LEXENV'>0  S LEXSEND="",LEXPRON="LEXICAL SERVICES UPDATE",LEXPRO=$G(^LEXM(0,"PRO"))
+ S:+LEXPRO>0 LEXPRO=$$FMTE^XLFDT(LEXPRO,"1"),LEXP=1 S LEXACCT=$$U^LEXXFI7 S ZTSAVE("LEXACCT")=""
+ S ZTRTN="ALL^LEXXFI",ZTSAVE("LEXSEND")="",ZTSAVE("LEXPOST")="" S:$D(LEXCOUNT) ZTSAVE("LEXCOUNT")=""
+ S:$L($G(LEXPRO))&($L($G(LEXPRON)))&(+($G(LEXP))>0) ZTSAVE("LEXPRO")="",ZTSAVE("LEXPRON")=""
+ S:$D(LEXLREV) ZTSAVE("LEXLREV")="" S:$D(LEXREQP) ZTSAVE("LEXREQP")="" S:$D(LEXBUILD) ZTSAVE("LEXBUILD")=""
+ S:$D(LEXSHORT) ZTSAVE("LEXSHORT")="" S:$D(LEXIGHF) ZTSAVE("LEXIGHF")="" S:$D(LEXCRE) ZTSAVE("LEXCRE")=""
+ S:$D(LEXID) ZTSAVE("LEXID")="" S:$D(XPDA) ZTSAVE("XPDA")=""
+ S (LEXDESC,ZTDESC)="Post-Install File Counts " S:$D(LEXSHORT) (LEXDESC,ZTDESC)="Post-Install Summary",ZTDTH=$H
+ S ZTIO="" D ^%ZTLOAD W:+($G(ZTSK))>0 !!,"  ",LEXDESC,!,"  Queued Task #",+($G(ZTSK)) W ! D ^%ZISC
  Q
 MAIL ; Mail global array in message
  N DIFROM,LEXPRI,LEXADR,LEXI,LEXM,LEXSUB,XCNP,XMDUZ,XMSCR,XMSUB,XMTEXT,XMY,XMZ
- I '$D(LEXSHORT),+$G(^TMP("LEXCS",$J,0))'>0 G MAILQ
- K ^TMP("LEXMSG",$J)
+ G:'$D(LEXSHORT)&(+($G(^TMP("LEXCS",$J,0)))'>0) MAILQ K ^TMP("LEXMSG",$J)
  S LEXSUB="Lexicon/ICD/CPT Installation"
  S:$L($G(LEXBUILD)) LEXSUB=$G(LEXBUILD)_" Installation"
- S LEXPRI=$$ADR^LEXXFI8
- G:'$L(LEXPRI) MAILQ
+ S LEXPRI=$$ADR^LEXXFI8 G:'$L(LEXPRI) MAILQ
  S LEXPRI="G.LEXINS@"_LEXPRI
- S LEXADR=$$GET1^DIQ(200,+($G(DUZ)),.01)
- G:'$L(LEXADR) MAILQ
+ S LEXADR=$$GET1^DIQ(200,+($G(DUZ)),.01) G:'$L(LEXADR) MAILQ
  S U="^",XMSUB="LEX/ICD/CPT File Checksums - "_$$FMTE^XLFDT($$NOW^XLFDT)
  S:$D(LEXCOUNT) XMSUB="LEX/ICD/CPT File Checksums/Counts - "_$$FMTE^XLFDT($$NOW^XLFDT)
  S:$L($G(LEXBUILD)) XMSUB=$G(LEXBUILD)_" File Checksums"
- I $L($G(LEXBUILD)),$D(LEXCOUNT) S XMSUB=$G(LEXBUILD)_" File Checksums/Counts"
+ S:$L($G(LEXBUILD))&($D(LEXCOUNT)) XMSUB=$G(LEXBUILD)_" File Checksums/Counts"
  S:$D(LEXPOST) XMSUB=LEXSUB
  S LEXI=0 F  S LEXI=$O(^TMP("LEXKID",$J,LEXI)) Q:+LEXI=0  D
@@ -127,7 +106,7 @@
  S XMY(LEXPRI)="",XMY(LEXADR)="",XMTEXT="^TMP(""LEXMSG"",$J,",XMDUZ=.5 D ^XMD
 MAILQ ; Quit Mail
- D KILL K XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMY,XMTEXT,XMDUZ
+ D KILL K %Z,XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMY,XMTEXT,XMDUZ
  Q
- ;
+ ;               
  ; Miscellaneous
 HDR ;   Header
@@ -161,6 +140,5 @@
  N LEXNM D HOME^%ZIS S U="^",DT=$$DT^XLFDT
  I +($G(DUZ))'>0 W !!,"    User (DUZ) not defined",! Q 0
- S LEXNM=$$GET1^DIQ(200,+($G(DUZ)),.01)
- I '$L(LEXNM) W !!,"    Invalid User (DUZ) defined",! Q 0
+ S LEXNM=$$GET1^DIQ(200,+($G(DUZ)),.01) I '$L(LEXNM) W !!,"    Invalid User (DUZ) defined",! Q 0
  S DTIME=$$DTIME^XUP(+($G(DUZ)))
  Q 1
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFI2 ; ISL/KER - File Info - Checksums            ; 07/28/2004
- ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996;Build 1
  Q
  ;            
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFI3 ; ISL/KER - File Info - Record Count            ; 07/28/2004
- ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996;Build 1
  Q
  ;            
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFI4 ; ISL/KER - File Info - Record Counts (2)      ; 07/28/2004
- ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996;Build 1
  Q
  ;                    
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI5.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI5.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI5.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFI5 ; ISL/KER - File Info - Versions/Revisions     ; 07/28/2004
- ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996;Build 1
  Q
  ;                    
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI6.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI6.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI6.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFI6 ; ISL/KER - File Info - DD Information      ; 07/28/2004
- ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996;Build 1
  Q
  ;                        
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI8.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI8.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFI8.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFI8 ; ISL/KER - File Info - Miscellaneous      ; 07/28/2004
- ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**32**;Sep 23, 1996;Build 1
  Q
  ;                    
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFQ.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXFQ.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXFQ.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXFQ ; ISL/FJF Set Frequencies in 757.001;04/08/03
- ;;2.0;LEXICON UTILITY;**4,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4,25**;Sep 23, 1996;Build 1
  Q
 EN ; Update term frequencies when not found  (at site)
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI.m	(revision 636)
@@ -1,16 +1,9 @@
-LEXXGI ;ISL/KER/FJF - Global Import (Needs ^LEXM) ;04/22/2008
- ;;2.0;LEXICON UTILITY;**4,25,26,27,28,29,46,49,50,41**;Sep 23, 1996;Build 34
+LEXXGI ; ISL/KER - Global Import (Needs ^LEXM) ; 02/22/2007
+ ;;2.0;LEXICON UTILITY;**4,25,26,27,28,29,46,49**;Sep 23, 1996;Build 3
  ;              
- ; NEWed by Lexicon Environment Check routine LEX20nn
- ;    LEXBUILD
- ;    LEXFY
- ;    LEXIGHF
- ;    LEXLREV
- ;    LEXPTYPE
- ;    LEXQTR
- ;    LEXREQP
+ ; NEWed or KILLed Elsewhere
  ;              
- ; NEWed by KIDS during the Install of a patch/build
- ;    XPDNM
+ ;    LEXBUILD, LEXFY, LEXIGHF, LEXLREV, LEXPTYPE
+ ;    LEXQTR, LEXREQP, LEXSHORT, XPDNM
  ;              
  ; Global Variables
@@ -18,11 +11,11 @@
  ;              
  ; External References
- ;    DBIA 10086  HOME^%ZIS
- ;    DBIA 10016  ^DIM
- ;    DBIA  2056  $$GET1^DIQ (file 200)
- ;    DBIA 10103  $$DT^XLFDT
- ;    DBIA 10103  $$FMTE^XLFDT
- ;    DBIA 10141  BMES^XPDUTL 
- ;    DBIA 10141  MES^XPDUTL
+ ;    HOME^%ZIS
+ ;    ^DIM     
+ ;    $$GET1^DIQ
+ ;    $$DT^XLFDT
+ ;    $$FMTE^XLFDT
+ ;    BMES^XPDUTL 
+ ;    MES^XPDUTL  
  ;              
 EN ; Main Entry Point for Installing LEXM in Post-Installs
@@ -70,21 +63,5 @@
  ;   LEXCRE   - Import Global Creation Date
  ;                
- D IMPORT D KALL^LEXXGI2
- Q
-TASK ; Queue Lexicon Update with Taskman
- N Y,ZTRTN,ZTDESC,ZTIO,ZTDTH,ZTSK,ZTSAVE,ZTQUEUED
- S:$D(LEXBUILD) ZTSAVE("LEXBUILD")=""
- S:$D(LEXMSG) ZTSAVE("LEXMSG")=""
- S:$D(LEXSHORT) ZTSAVE("LEXSHORT")=""
- S:$D(LEXPTYPE) ZTSAVE("LEXPTYPE")=""
- S:$D(LEXLREV) ZTSAVE("LEXLREV")=""
- S:$D(LEXREQP) ZTSAVE("LEXREQP")=""
- S:$D(LEXIGHF) ZTSAVE("LEXIGHF")=""
- S:$D(LEXFY) ZTSAVE("LEXFY")=""
- S:$D(LEXQTR) ZTSAVE("LEXQTR")=""
- S:$D(LEXCRE) ZTSAVE("LEXCRE")=""
- S ZTRTN="EN^LEXXGI",ZTDESC="Importing Updated Lexicon Data"
- S ZTIO="",ZTDTH=$H
- D ^%ZTLOAD,HOME^%ZIS
+ D IMPORT,KALL^LEXXGI2
  Q
 IMPORT ; Import Data during a Patch Installation
@@ -109,5 +86,5 @@
  . S:$D(LEXSCHG("C","CPT"))!($D(LEXSCHG("C","ICD"))) LEXSCHG("D","PRO")="",LEXCHG=1,LEXSCHG(0)=1
  . D LOAD,NOTIFY^LEXXGI2 I +($G(DUZ))>0,$L($$GET1^DIQ(200,(+($G(DUZ))_","),.01)) D
- . . D HOME^%ZIS N DIFROM,LEXPRO,LEXPRON,LEXLAST S LEXPRON="LEXICAL SERVICES UPDATE",LEXPRO=$G(^LEXM(0,"PRO")) D:$D(LEXMSG) POST^LEXXFI
+ . . D HOME^%ZIS N DIFROM,LEXPRO,LEXPRON,LEXLAST D:$D(LEXMSG) POST^LEXXFI
  Q
 LOAD ; Load Data from ^LEXM into IC*/LEX Files
@@ -142,5 +119,5 @@
  . N LEXB,LEXFID,LEXNM,LEXVR,LEXRV,LEXDT,LEXL1,LEXL2 S (LEXL1,LEXL2)="",LEXFID=$P(LEXFI,".",1)
  . Q:+LEXFID'>0  Q:$D(LEXHDRS(+LEXFID))  S LEXHDRS(LEXFID)="" S:+LEXFI=81!(+LEXFI=81.3) LEXHDRS(81)="",LEXHDRS(81.3)=""
- . S:LEXFID=80 LEXNM="ICD-9-CM" S:LEXFID=81 LEXNM="CPT-4/HCPCS" S:LEXFID=757 LEXNM="Lexicon" S LEXB=$G(^LEXM(LEXFI,0,"BUILD"))
+ . S:LEXFID=80 LEXNM="ICD-9-CM" S:LEXFID=81 LEXNM="CPT-4/HCPSC" S:LEXFID=757 LEXNM="Lexicon" S LEXB=$G(^LEXM(LEXFI,0,"BUILD"))
  . S LEXVR=$G(^LEXM(LEXFI,0,"VR")),LEXRV=$G(^LEXM(LEXFI,0,"VRRV")),LEXDT=$$MIX^LEXXGI2($$FMTE^XLFDT($P(LEXRV,"^",2))),LEXRV=$P(LEXRV,"^",1)
  . S LEXL1="Updating "_LEXNM S:$L(LEXB) LEXL1=LEXL1_" with patch/build "_LEXB S:$L(LEXVR) LEXL2=" To version "_LEXVR
@@ -190,5 +167,2 @@
  K ZTDESC,ZTDTH,ZTIO,ZTQUEUED,ZTREQ,ZTRTN,ZTSAVE,ZTSK
  Q
-CHECKSUM ; Check ^LEXM Checksum
- D CS^LEXXGI2
- Q
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXGI2.m	(revision 636)
@@ -1,25 +1,22 @@
-LEXXGI2 ;ISL/KER - Global Import (Update Change File w/^LEXM) ;06/06/2007
- ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49,50**;Sep 23, 1996
+LEXXGI2 ; ISL/KER - Global Import (Update Change File w/^LEXM)  ; 02/22/2007
+ ;;2.0;LEXICON UTILITY;**25,26,28,29,46,49**;Sep 23, 1996;Build 3
  ;             
- ; Variables NEWed or KILLed Elsewhere
- ;    XPDNM  NEWed by KIDS during Install
- ;              
  ; Global Variables
- ;    ^LEXM
- ;    DBIA   872  ^ORD(101
- ;    DBIA 10011  ^UTILITY($J
- ;              
+ ;   ^LEXM(
+ ;   DBIA 10011  ^UTILITY($J
+ ;             
  ; External References
- ;    DBIA  10011  ^DIWP
- ;    DBIA 10103  $$FMDIFF^XLFDT
- ;    DBIA 10103  $$NOW^XLFDT
- ;    DBIA 10141  BMES^XPDUTL 
- ;    DBIA 10141  MES^XPDUTL
- ;    DBIA 10101  EN^XQOR
- ;              
+ ;   DBIA 10011  ^DIWP
+ ;   DBIA 10103  $$NOW^XLFDT
+ ;   DBIA 10103  $$FMDIFF^XLFDT
+ ;   DBIA 10141  BMES^XPDUTL
+ ;   DBIA 10141  MES^XPDUTL
+ ;             
+ ; XPDNM   Newed by KIDS during Install
  Q
 NOTIFY ; Notify by Protocol - LEXICAL SERVICES UPDATE
  ;     Uses LEXSCHG() from the Post-Install
  ;     Sets ^LEXM(0,"PRO")=$$NOW^XLFDT
+ W !!,"NOTIFY^LEXXGI1",!
  N X,LEXU,LEXT,LEXF,LEXI,LEXL,LEX1,LEX2,LEX3,LEXN,LEXP,LEXUP D:$O(LEXSCHG(0))'>0 SCHG
  S LEXUP="" S:$D(LEXSCHG("C","ICD"))!($D(LEXSCHG(80)))!($D(LEXSCHG(80.1))) LEXUP=$G(LEXUP)_"ICD"
@@ -52,5 +49,5 @@
  Q
 UPCHG ;
- Q:+($G(LEXFI))'>0  N LEXID S LEXID=$S($P(LEXFI,".",1)="757":"LEX",$P(LEXFI,".",1)="80":"ICD",$P(LEXFI,".",1)="81":"CPT",1:"UNK")
+ Q:+LEXFI'>0  N LEXID S LEXID=$S($P(LEXFI,".",1)="757":"LEX",$P(LEXFI,".",1)="80":"ICD",$P(LEXFI,".",1)="81":"CPT",1:"UNK")
  I $D(LEXSCHG) S LEXSCHG(LEXFI,0)="",LEXSCHG("B",LEXFI)="",LEXSCHG("C",LEXID,LEXFI)=""
  Q
@@ -79,26 +76,4 @@
  S (LEXSCHG("757.1",0),LEXSCHG("B","757.1"),LEXSCHG("C","LEX","757.1"))=""
  Q
-CS ;   Checksum for import global
- N LEXCHK,LEXNDS,LEXVER S LEXCHK=+($G(^LEXM(0,"CHECKSUM")))
- W !,"   Running checksum routine on the ^LEXM import global, please wait"
- S LEXNDS=+($G(^LEXM(0,"NODES"))),LEXVER=+($$VC(LEXCHK,LEXNDS)) W !
- W:LEXVER>0 !,"     Checksum is ok",! Q:LEXVER>0
- I LEXVER=0 W !!,"   Import global ^LEXM is missing.  Please obtain a copy of ^LEXM before",!,"   continuing." Q
- I LEXVER<0 D  Q
- . I LEXVER'=-3 W !,"   Unable to verify checksum for import global ^LEXM (possibly corrupt)"
- . I LEXVER=-3 W !,"   Import global ^LEXM failed checksum"
- . W !!,"     Please KILL the existing import global ^LEXM from your system and"
- . W !,"     obtain a new copy of ^LEXM before continuing with the installation."
- Q
-VC(X,Y) ;   Verify Checksum for import global
- Q:'$D(^LEXM)!('$D(^LEXM(0)))!($O(^LEXM(0))'>0) 0  N LEXCHK,LEXNDS,LEXCNT,LEXLC,LEXL,LEXS,LEXNC,LEXD,LEXN,LEXC,LEXGCS,LEXP,LEXT
- S LEXCHK=+($G(X)),LEXNDS=+($G(Y)) Q:LEXCHK'>0!(LEXNDS'>0) -2  S LEXL=64,(LEXCNT,LEXLC)=0,LEXS=(+(LEXNDS\LEXL))
- S:LEXS=0 LEXS=1 W:+($O(^LEXM(0)))>0 ! S (LEXC,LEXN)="^LEXM",(LEXNC,LEXGCS)=0 W "   "
- F  S LEXN=$Q(@LEXN) Q:LEXN=""!(LEXN'[LEXC)  D
- . Q:LEXN="^LEXM(0,""CHECKSUM"")"  Q:LEXN="^LEXM(0,""NODES"")"  S LEXCNT=LEXCNT+1
- . I LEXCNT'<LEXS S LEXLC=LEXLC+1 W:LEXLC'>LEXL "." S LEXCNT=0
- . S LEXNC=LEXNC+1,LEXD=@LEXN,LEXT=LEXN_"="_LEXD F LEXP=1:1:$L(LEXT) S LEXGCS=$A(LEXT,LEXP)*LEXP+LEXGCS
- Q:LEXNC'=LEXNDS -3  Q:LEXGCS'=LEXCHK -3
- Q 1
  ; Miscellaneous
 NF ;   Import Global Not Found
@@ -157,10 +132,4 @@
  K ^UTILITY($J,"W")
  Q
-CLR ;   Clear
- K %,%DT,C,CT,D,D0,D1,D2,DA,DG,DIC,DICR,DILOCKTM,DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,DTOUT
- K DUOUT,END,FI,I,ID,IREC,J,L,LENGTH,LEX,LEX1,LEX2,LEX3,LEXB,LEXBUILD,LEXC,LEXCD,LEXCHG,LEXCHK,LEXCNT
- K LEXD,LEXE,LEXF,LEXFI,LEXFY,LEXGCS,LEXI,LEXID,LEXIGHF,LEXL,LEXLAST,LEXLC,LEXLREV,LEXN,LEXNC,LEXNDS,LEXP
- K LEXPTYPE,LEXQTR,LEXREQP,LEXS,LEXSCHG,LEXSTR,LEXT,LEXU,LEXUP,LEXVER,LEXX,TI,X,X1,X2,XMDUN,XMZ,Y,Z,ZTSK
- Q
 TRIM(X) ;   Trim Spaces
  S X=$G(X) Q:X="" X F  Q:$E(X,1)'=" "  S X=$E(X,2,$L(X))
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXII.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXII.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXII.m	(revision 636)
@@ -1,12 +1,5 @@
-LEXXII ;ISL/KER - Lexicon Status (Install Info) ;06/06/2007
- ;;2.0;LEXICON UTILITY;**32,46,49,50,41**;Sep 23, 1996;Build 34
- ;              
- ; Variables NEWed or KILLed Elsewhere
- ;   LEXACCT  NEWed by LEXXFI sending message
- ;   LEXID    NEWed by LEXXFI sending message
- ;   LEXCRE   NEWed by LEXXGI loading data
- ;   LEXIGHF  NEWed by Post Install routine LEX20nnP
- ;   XPDA     NEWed by KIDS during Install
- ;              
+LEXXII ; ISL/KER - Lexicon Status (Install Info) ; 01/01/2007
+ ;;2.0;LEXICON UTILITY;**32,46,49**;Sep 23, 1996;Build 3
+ ;             
  ; Global Variables
  ;   DBIA 10096  ^%ZOSF("PROD"
@@ -14,6 +7,6 @@
  ;   DBIA 10060  ^VA(200
  ;   ^LEXM(0
- ;   ^TMP("LEX*",$J    SACC 2.3.2.5.1
- ;              
+ ;   ^TMP("LEX*",$J    SACC 2.3.2.5.1 
+ ;             
  ; External References
  ;   DBIA 10103  $$FMTE^XLFDT
@@ -23,5 +16,9 @@
  ;   DBIA  2051  FIND^DIC
  ;   DBIA  2056  GETS^DIQ
- ;              
+ ;             
+ ; LEXCRE   Newed in LEXXGI
+ ; LEXID    Newed in LEXXFI
+ ; LEXIGHF  Newed in Post-Install LEX20nnP
+ ;            
 EN ; Main Entry
  N LEXSUB S LEXSUB=$G(LEXID) S:LEXSUB="" LEXSUB="LEXXII" K ^TMP(LEXSUB,$J) D II
@@ -29,7 +26,6 @@
  ;                               
 II ; Install Information
- N LEXT,LEXA,LEXACT,LEXB,LEXD,LEXE,LEXL,LEXU,LEXN,LEXP,LEXPROF,LEXDA H 2
- S LEXA="",LEXACT=$G(LEXACCT),LEXPRO=$G(LEXPRO),LEXPRON=$G(LEXPRON)
- S:'$L(LEXPRON) LEXPRON="LEXICAL SERVICES UPDATE" S:'$L(LEXPRO) LEXPRO=$G(^LEXM(0,"PRO")) S:+LEXPRO>0 LEXPRO=$$ED(LEXPRO)
+ N LEXT,LEXA,LEXACT,LEXB,LEXD,LEXE,LEXL,LEXU,LEXN,LEXP,LEXPRO,LEXPRON,LEXPROF,LEXDA H 2
+ S LEXA="",LEXACT=$G(LEXACCT),LEXPRON="LEXICAL SERVICES UPDATE",LEXPRO=$G(^LEXM(0,"PRO")) S:+LEXPRO>0 LEXPRO=$$ED(LEXPRO),LEXPROF=1
  S LEXT="Lexicon/ICD/CPT Installation" D TL(LEXT)
  S LEXT="============================" D TL(LEXT),BL
@@ -52,8 +48,7 @@
  S:'$L(LEXT)&($L($G(LEXCRE)))&($P($G(LEXCRE),".",1)?7N) LEXT="  Created:     "_$$ED($G(LEXCRE))
  D:$L(LEXT) TL(LEXT)
- S LEXT="" I $L($G(LEXPRO))&($L($G(LEXPRON))) D
+ S LEXT="" I $L($G(LEXPRO))&($L($G(LEXPRON)))&(+($G(LEXPROF))>0) D
  . S LEXT="  Protocol:    "_LEXPRON D BL,TL(LEXT)
  . S LEXT="  Invoked:     "_LEXPRO D TL(LEXT)
- . K LEXPRO,LEXPRON,^LEXM(0,"PRO")
  S LEXB=$$SS($G(LEXBUILD)),LEXE=$P(LEXB,"^",2),LEXL=$P(LEXB,"^",3),LEXB=$P(LEXB,"^",1)
  I $P(LEXB,".",1)?7N!($P(LEXB,".",2)?7N)!($P(LEXB,".",3)[":") D
@@ -87,5 +82,6 @@
  . D GETS^DIQ(9.7,LEXIENS,"11;17","I","LEXOUT")
  . S LEXL=0,LEXB=$G(LEXOUT(9.7,LEXIENS,11,"I"))
- . S LEXE=$$NOW^XLFDT
+ . S LEXE=$G(LEXOUT(9.7,LEXIENS,17,"I"))
+ . S:+LEXE'>0 LEXE=$$NOW^XLFDT
  . S:+LEXB>0&(+LEXE>0) LEXL=$$EP(LEXB,LEXE)
  . S LEX=LEXB_"^"_LEXE S:$L(LEXL) $P(LEX,"^",3)=LEXL
@@ -93,5 +89,5 @@
  . S LEX="" S LEXDA=+($G(LEXD)) Q:+LEXDA'>0
  . S LEXL="",LEXB=$P($G(LEXD),"^",2) Q:$P(LEXB,".",1)'?7N
- . S LEXE=$$NOW^XLFDT
+ . S LEXE=$P($G(LEXD),"^",3) Q:$P(LEXE,".",1)'?7N
  . S:+LEXB>0&(+LEXE>0) LEXL=$$EP(LEXB,LEXE)
  . S LEX=LEXB_"^"_LEXE S:$L(LEXL) $P(LEX,"^",3)=LEXL
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXST2.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXST2.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXST2.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXST2 ; ISL Lexicon Status (Routine Count)       ; 12-08-97
- ;;2.0;LEXICON UTILITY;**4,5,8**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4,5,8**;Sep 23, 1996;Build 1
  Q
 RTT ; Total Routines
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXST3.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXST3.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXST3.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXST3 ; ISL Lexicon Status (KIDS/Routines Patch) ; 05/14/2003
- ;;2.0;LEXICON UTILITY;**4,5,8,25**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4,5,8,25**;Sep 23, 1996;Build 1
  Q
 KIDS ; KIDS entries
Index: FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXST4.m
===================================================================
--- FOIAVistA/trunk/r/LEXICON_UTILITY-LEX-GMPT/LEXXST4.m	(revision 631)
+++ FOIAVistA/tag/r/LEXICON_UTILITY-LEX-GMPT/LEXXST4.m	(revision 636)
@@ -1,4 +1,4 @@
 LEXXST4 ; ISL Lexicon Status (Dates)               ; 05-17-97
- ;;2.0;LEXICON UTILITY;**4,5**;Sep 23, 1996
+ ;;2.0;LEXICON UTILITY;**4,5**;Sep 23, 1996;Build 1
  Q
 DTS(LEXX) ; Date to sequential
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX1.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX1.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX1.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX1 ; DRIVER FOR COMPILED XREFS FOR FILE #680 ; 10/15/04
+LBRYX1 ; DRIVER FOR COMPILED XREFS FOR FILE #680 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX11.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX11.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX11.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX11 ; COMPILED XREF FOR FILE #680 ; 10/15/04
+LBRYX11 ; COMPILED XREF FOR FILE #680 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX12.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX12.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX12.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX12 ; COMPILED XREF FOR FILE #680.01 ; 10/15/04
+LBRYX12 ; COMPILED XREF FOR FILE #680.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX13.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX13.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX13.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX13 ; COMPILED XREF FOR FILE #680.03 ; 10/15/04
+LBRYX13 ; COMPILED XREF FOR FILE #680.03 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX14.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX14.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX14.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX14 ; COMPILED XREF FOR FILE #680 ; 10/15/04
+LBRYX14 ; COMPILED XREF FOR FILE #680 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX15.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX15.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX15.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX15 ; COMPILED XREF FOR FILE #680.01 ; 10/15/04
+LBRYX15 ; COMPILED XREF FOR FILE #680.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX16.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX16.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX16.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX16 ; COMPILED XREF FOR FILE #680.03 ; 10/15/04
+LBRYX16 ; COMPILED XREF FOR FILE #680.03 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX2.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX2.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX2.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX2 ; DRIVER FOR COMPILED XREFS FOR FILE #681 ; 10/15/04
+LBRYX2 ; DRIVER FOR COMPILED XREFS FOR FILE #681 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX21.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX21.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX21.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX21 ; COMPILED XREF FOR FILE #681 ; 10/15/04
+LBRYX21 ; COMPILED XREF FOR FILE #681 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX22.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX22.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX22.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX22 ; COMPILED XREF FOR FILE #681.02 ; 10/15/04
+LBRYX22 ; COMPILED XREF FOR FILE #681.02 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX23.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX23.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX23.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX23 ; COMPILED XREF FOR FILE #681 ; 10/15/04
+LBRYX23 ; COMPILED XREF FOR FILE #681 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX24.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX24.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX24.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX24 ; COMPILED XREF FOR FILE #681.02 ; 10/15/04
+LBRYX24 ; COMPILED XREF FOR FILE #681.02 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX3.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX3.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX3.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX3 ; DRIVER FOR COMPILED XREFS FOR FILE #682 ; 10/15/04
+LBRYX3 ; DRIVER FOR COMPILED XREFS FOR FILE #682 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX31.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX31.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX31.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX31 ; COMPILED XREF FOR FILE #682 ; 10/15/04
+LBRYX31 ; COMPILED XREF FOR FILE #682 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX32.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX32.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX32.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX32 ; COMPILED XREF FOR FILE #682.04 ; 10/15/04
+LBRYX32 ; COMPILED XREF FOR FILE #682.04 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX33.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX33.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX33.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX33 ; COMPILED XREF FOR FILE #682 ; 10/15/04
+LBRYX33 ; COMPILED XREF FOR FILE #682 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX34.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX34.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX34.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX34 ; COMPILED XREF FOR FILE #682.04 ; 10/15/04
+LBRYX34 ; COMPILED XREF FOR FILE #682.04 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX4.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX4.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX4.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX4 ; DRIVER FOR COMPILED XREFS FOR FILE #682.1 ; 10/15/04
+LBRYX4 ; DRIVER FOR COMPILED XREFS FOR FILE #682.1 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX41.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX41.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX41.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX41 ; COMPILED XREF FOR FILE #682.1 ; 10/15/04
+LBRYX41 ; COMPILED XREF FOR FILE #682.1 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX42.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX42.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX42.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX42 ; COMPILED XREF FOR FILE #682.129 ; 10/15/04
+LBRYX42 ; COMPILED XREF FOR FILE #682.129 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX43.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX43.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX43.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX43 ; COMPILED XREF FOR FILE #682.132 ; 10/15/04
+LBRYX43 ; COMPILED XREF FOR FILE #682.132 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX44.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX44.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX44.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX44 ; COMPILED XREF FOR FILE #682.1 ; 10/15/04
+LBRYX44 ; COMPILED XREF FOR FILE #682.1 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX45.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX45.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX45.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX45 ; COMPILED XREF FOR FILE #682.129 ; 10/15/04
+LBRYX45 ; COMPILED XREF FOR FILE #682.129 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX46.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX46.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX46.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX46 ; COMPILED XREF FOR FILE #682.132 ; 10/15/04
+LBRYX46 ; COMPILED XREF FOR FILE #682.132 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX5.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX5.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX5.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX5 ; DRIVER FOR COMPILED XREFS FOR FILE #680.5 ; 10/15/04
+LBRYX5 ; DRIVER FOR COMPILED XREFS FOR FILE #680.5 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX51.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX51.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX51.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX51 ; COMPILED XREF FOR FILE #680.5 ; 10/15/04
+LBRYX51 ; COMPILED XREF FOR FILE #680.5 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX52.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX52.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX52.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX52 ; COMPILED XREF FOR FILE #680.53 ; 10/15/04
+LBRYX52 ; COMPILED XREF FOR FILE #680.53 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX53.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX53.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX53.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX53 ; COMPILED XREF FOR FILE #680.5 ; 10/15/04
+LBRYX53 ; COMPILED XREF FOR FILE #680.5 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX54.m
===================================================================
--- FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYX54.m	(revision 631)
+++ FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRYX54.m	(revision 636)
@@ -1,3 +1,3 @@
-LBRYX54 ; COMPILED XREF FOR FILE #680.53 ; 10/15/04
+LBRYX54 ; COMPILED XREF FOR FILE #680.53 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MAILMAN-XM/XMRUCX.m
===================================================================
--- FOIAVistA/trunk/r/MAILMAN-XM/XMRUCX.m	(revision 631)
+++ FOIAVistA/tag/r/MAILMAN-XM/XMRUCX.m	(revision 636)
@@ -1,7 +1,24 @@
-XMRUCX ;(WASH ISC)/THM/CAP-SMTP Receiver (RFC 821) for UCX ;03/25/2004  06:33
- ;;8.0;MailMan;**6,19,25,27**;Jun 28, 2002
+XMRUCX ;(WASH ISC)/THM/CAP-SMTP Receiver (RFC 821) for UCX ;6:10 AM  31 Jan 2008
+ ;;8.0;MailMan;**6,19,25,27,test**;Jun 28, 2002;Build 4
  ;
  ;Entry for Inet_servers interface RECEIVER
  ;SMTP service request invokes MailMan
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 SOC25 ;
  ;S (XMRPORT,IO,IO(0))=%,X=$E(%_"-INETMM",1,15) D SETENV^%ZOSV
@@ -30,5 +47,4 @@
  N $ETRAP,$ESTACK S $ETRAP="D ^%ZTER S ZZIO=$ZIO H 33 D R^XMCTRAP Q"
  S XMRPORT=IO
- D SETNM^%ZOSV($E(IO_"INETMM",1,15)),COUNT^XUSCNT(1) ;Process counting under GT.M
  N DIQUIET S DIQUIET=1 D DT^DICRW,DUZ^XUP(.5)
  S ER=0,XMS0C=1
@@ -41,4 +57,17 @@
  D LISTEN^%ZISTCPS(25,"GTM2^XMRUCX")
  Q
+ ;
+GTMLNX ;From Linux xinetd script
+ S U="^",$ETRAP="D ^%ZTER S ZZIO=$ZIO H 33 D R^XMCTRAP Q"
+ ;GTM specific code
+ S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
+ S (XMRPORT,IO,IO(0))=$P X "U XMRPORT:(nowrap:delimiter=$C(13))"
+ S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
+ D SETNM^%ZOSV($E(XMRPORT_"INETMM",1,15)),COUNT^XUSCNT(1) ;Process counting under GT.M
+ S XMCHAN="TCP/GTM",XMNO220=""
+ N DIQUIET S DIQUIET=1 D DT^DICRW,DUZ^XUP(.5)
+ D ENT^XMR
+ D COUNT^XUSCNT(-1) ;Check out GT.M counting
+ Q
 CACHEVMS ;Cache/VMS tcpip service entry point
  N $ETRAP,$ESTACK S $ETRAP="S ZZIO=$ZIO H 33 D R^XMCTRAP Q"
Index: FOIAVistA/tag/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFAPI.m
===================================================================
--- FOIAVistA/trunk/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFAPI.m	(revision 631)
+++ FOIAVistA/tag/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFAPI.m	(revision 636)
@@ -1,4 +1,26 @@
 MPIFAPI ;CMC/BP-APIS FOR MPI ;DEC 21, 1998
- ;;1.0; MASTER PATIENT INDEX VISTA ;**1,3,14,16,17,21,27,28,33,35,37,43,45,44,46,48**;30 Apr 99;Build 6
+ ;;1.0; MASTER PATIENT INDEX VISTA ;**1,3,14,16,17,21,27,28,33,35,37,43,45,44,46,48,40**;30 Apr 99;Build 13
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ; 2/5/2005  DAOU/WCJ: VOE patch created
+ ; 4/22/2005 ALB/PTD: MPIF*1*37
+ ; 9/14/2005 VA/CJS: VOE patch reworked as MPIF*1*40 T1
+ ; 4/3/2006  WV/TOAD: VOE patch reapplied after YS*5.01*37
+ ;
  ; Integration Agreements Utilized:
  ;   ^DPT( - #2070 and #4079
@@ -93,5 +115,19 @@
  ...I MPIFARR(2,DFN,.09,"E")["P",("S"[MPIFARR(2,DFN,.0906,"I")) S MPIFP=".0906;"
  ..S DIE="^DPT(",DA=DFN,DIE("NO^")="BACK"
- ..S DR=MPIFP_".2403;.092;.093;1",DR(2,2.01)=".01" D ^DIE K DA,DIE,DR Q
+ ..; start of VOE change part 1 of 2
+ ..; if agency is EHR or IHS, ask Health Record Number before other fields
+ ..;
+ ..; before change
+ ..;S DR=MPIFP_".2403;.092;.093;1",DR(2,2.01)=".01" D ^DIE K DA,DIE,DR Q
+ ..;
+ ..; after change
+ ..S DR=MPIFP_".2403;.092;.093;1"
+ ..I "EI"[$G(DUZ("AG")) S DR="D HRN^MPIFAG1;"_DR
+ ..S DR(2,2.01)=".01"
+ ..D ^DIE
+ ..K DA,DIE,DR
+ ..;
+ ..; end of VOE change 1 of 2
+ ..;
  .I $G(DGNEW)="" D  ;Existing patient, get current values
  ..N MPIDOB,IMPRS,MPIMMN,MPICTY,MPIST
@@ -124,4 +160,12 @@
  ...I MPIFARR(2,DFN,.09,"E")["P",(MPIFARR(2,DFN,.0906,"I")="") S DR=DR_".0906;" ;**48 correct when SSN is prompted
  ...I MPIFARR(2,DFN,.09,"E")["P",(MPIFARR(2,DFN,.0906,"I")="S") S DR=DR_".09;" ;**48 correct when SSN is prompted
+ ..;
+ ..; start of VOE change part 2 of 2
+ ..; if agency is EHR or IHS, ask Health Record Number after SSN
+ ..;
+ ..I "EI"[$G(DUZ("AG")) S DR=DR_"D HRN^MPIFAG1;"
+ ..;
+ ..; end of VOE change 2 of 2
+ ..;
  ..I $G(MPIFARR(2,DFN,994,"I"))="" S DR=DR_"994;" ;MULTIPLE BIRTH INDICATOR
  ..S MPIMMN=$G(MPIFARR(2,DFN,.2403,"E")) ;MOTHER'S MAIDEN NAME
Index: FOIAVistA/tag/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFQ0.m
===================================================================
--- FOIAVistA/trunk/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFQ0.m	(revision 631)
+++ FOIAVistA/tag/r/MASTER_PATIENT_INDEX_VISTA-MPIF/MPIFQ0.m	(revision 636)
@@ -1,11 +1,6 @@
-MPIFQ0 ;ALB/RJS-QUERY HANDLER TOP LEVEL ;JUL 11, 1997
- ;;1.0; MASTER PATIENT INDEX VISTA ;**1,3,8,14,13,16,17,21,20,24,26,28,31,33,35,38,43**;30 Apr 99
- ;
- ; Integration Agreements utilized:
- ;  EXC, START and STOP^RGHLLOG - #2796
- ;  FILE^VAFCTFU - #2988
- ;  $$EN^HLCSAC - #3471
- ;  NAME^VAFCPID2 - #3492
- ;
+MPIFQ0 ;ALB/RJS-QUERY HANDLER TOP LEVEL ;2/8/07  22:22
+ ;;1.0; MASTER PATIENT INDEX VISTA ;**1,3,8,14,13,16,17,21,20,24,26,28,31,33,35,38,43,40**;30 Apr 99;Build 13
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
 INTACTV ;Interactive standalone query
  N DFN,NAME1,MPIFLL
@@ -23,5 +18,5 @@
  I $G(LOCDATA(2,DFN,991.01))>0&('$D(MPIFLL)) W:'$D(MPIFRPC) !,"Patient already has an ICN" G END
  S HLP("ACKTIME")=300,MPIQRYNM="EXACT_MATCH_QUERY"
- ;MPIQRYNM="VTQ_PID_ICN_NO_LOAD" **43 CHANGING QUERY NAME
+ ;MPIQRYNM="VTQ_PID_ICN_NO_LOAD" CHANGING QUERY NAME
  G JUMP
 VTQ G:$G(DFN)']"" END
@@ -29,7 +24,11 @@
  D GETDATA("^DPT(",DFN,"LOCDATA",".01;.02;.03;.09;.301;391;1901")
  S LOCDATA(2,DFN,991.01)=$P($$MPINODE^MPIFAPI(DFN),"^"),TSSN=LOCDATA(2,DFN,.09)
- ;S MPIQRYNM="VTQ_PID_ICN_NO_LOAD" **43 CHANGING QUERY NAME
+ ;S MPIQRYNM="VTQ_PID_ICN_NO_LOAD" CHANGING QUERY NAME
  S MPIQRYNM="EXACT_MATCH_QUERY"
  I $G(LOCDATA(2,DFN,991.01))>0 S MPIFRTN="ALREADY HAS ICN" G END ;If Pt already has ICN don't connect to MPI
+ ;New VOE code
+ ;Agency EHR does not use MPI
+ I '($G(DUZ("AG"))="V"!$$GET^XPAR("SYS","MPIF VOE MPI")) G END ;DAOU/WCJ;WV/CJS
+ ;End EHR modifications
 JUMP N TIME,% D NOW^%DTC S TIME=%
  N HL,MPIINM,MPIOUT,MPIIN,MPIMCNT,MPICNT,MPICS,HEADER,TEST,SITE,MPIDC,SSN
@@ -69,5 +68,5 @@
  .I '$D(MPIFS) W:'$D(MPIFRPC) !!,"Exact match for Patient was not found in the MPI..."
  .D A28^MPIFQ3(DFN) S MPIFRTN="DID A28"
- .;**43 log potential match exception if exist
+ .; log potential match exception if exist
  .I MPIPOT=1 D
  ..D START^RGHLLOG(0),EXC^RGHLLOG(218,"Potential match(es) found, please review via MPI/PD Exception Handler",DFN),STOP^RGHLLOG(0)
@@ -75,5 +74,5 @@
  ;If INDEX=1 it means we got 1 match check SSN see if definitely same pt
  I (INDEX=1) D  G EXIT
- .;**43 Removed &(TSSN=SSN) from line above as there will only be an exact match returned now
+ .; Removed &(TSSN=SSN) from line above, only be an exact match returned now
  .N CCMOR,ICN,DATA,TICN,SNM,SNM2,IEN
  .S DATA=^TMP("MPIFVQQ",$J,INDEX,"DATA"),CMOR=$P(DATA,"^",5),ICN=$P(DATA,"^",6),IEN=$$IEN^XUAF4(CMOR)
@@ -132,5 +131,5 @@
  N RESLT S RESLT=$$A24^MPIFA24B(DFN)
  I +RESLT<0 D EXC^RGHLLOG(208,"Problem building A24 (ADD TF) for DFN= "_DFN,DFN)
- ; Added for patch 31, create treating facility list
+ ; create treating facility list
  I $D(^TMP("MPIFVQQ",$J,INDEX,"TF")) D
  . N MPINTFI,MPINTF,TFSTRG,TFIEN,MPIFMDT
@@ -144,6 +143,4 @@
  Q
 GETDATA(DIC,DA,MPIFAR,DR,EI) ;
- ;This function returns the values stored in the fields via FM call DIQ1
- ;DIC=file reference, DA=IEN in file, ARRAY=array for the values to be stored in, DR=fields requested, EI=external/internal values
  N DIQ S DIQ=MPIFAR
  I $G(EI)]"" S DIQ(0)=EI
@@ -164,5 +161,5 @@
 RDF ;
  Q
-QAK ;**43 added check for potential matches
+QAK ; check potential matches
  K MPIPOT S MPIPOT=0
  I MSG(1)["POTENTIAL MATCHES" S MPIPOT=1
@@ -189,3 +186,2 @@
  S ^TMP("MPIFVQQ",$J,INDEX,0)=STRING,^TMP("MPIFVQQ",$J,"IDX",INDEX,INDEX)=""
  Q
- Q
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAA ; DRIVER FOR COMPILED XREFS FOR FILE #600.7 ; 10/15/04
+YSXRAA ; DRIVER FOR COMPILED XREFS FOR FILE #600.7 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAA1 ; COMPILED XREF FOR FILE #600.7 ; 10/15/04
+YSXRAA1 ; COMPILED XREF FOR FILE #600.7 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAA2 ; COMPILED XREF FOR FILE #600.71 ; 10/15/04
+YSXRAA2 ; COMPILED XREF FOR FILE #600.71 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAA3 ; COMPILED XREF FOR FILE #600.7 ; 10/15/04
+YSXRAA3 ; COMPILED XREF FOR FILE #600.7 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAA4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAA4 ; COMPILED XREF FOR FILE #600.71 ; 10/15/04
+YSXRAA4 ; COMPILED XREF FOR FILE #600.71 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAB ; DRIVER FOR COMPILED XREFS FOR FILE #601 ; 10/15/04
+YSXRAB ; DRIVER FOR COMPILED XREFS FOR FILE #601 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAB1 ; COMPILED XREF FOR FILE #601 ; 10/15/04
+YSXRAB1 ; COMPILED XREF FOR FILE #601 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAB2 ; COMPILED XREF FOR FILE #601.01 ; 10/15/04
+YSXRAB2 ; COMPILED XREF FOR FILE #601.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAB3 ; COMPILED XREF FOR FILE #601 ; 10/15/04
+YSXRAB3 ; COMPILED XREF FOR FILE #601 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAB4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAB4 ; COMPILED XREF FOR FILE #601.01 ; 10/15/04
+YSXRAB4 ; COMPILED XREF FOR FILE #601.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC ; DRIVER FOR COMPILED XREFS FOR FILE #601.2 ; 12/28/04
+YSXRAC ; DRIVER FOR COMPILED XREFS FOR FILE #601.2 ; 04/07/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC1 ; COMPILED XREF FOR FILE #601.2 ; 12/28/04
+YSXRAC1 ; COMPILED XREF FOR FILE #601.2 ; 04/07/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC2 ; COMPILED XREF FOR FILE #601.21 ; 12/28/04
+YSXRAC2 ; COMPILED XREF FOR FILE #601.21 ; 04/07/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC3 ; COMPILED XREF FOR FILE #601.22 ; 12/28/04
+YSXRAC3 ; COMPILED XREF FOR FILE #601.22 ; 04/07/05
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
@@ -11,5 +11,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" D KILL^YTCROSS
-CR1 S DIXR=476
+CR1 S DIXR=491
  K X
  S X(1)=$P(DIKZ(0),U,1)
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC4 ; COMPILED XREF FOR FILE #601.2213 ; 12/28/04
+YSXRAC4 ; COMPILED XREF FOR FILE #601.2213 ; 04/07/05
  ; 
  S DA(3)=DA(2) S DA(2)=0 S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC5.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC5 ; COMPILED XREF FOR FILE #601.2 ; 12/28/04
+YSXRAC5 ; COMPILED XREF FOR FILE #601.2 ; 04/07/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC6.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC6.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC6.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC6 ; COMPILED XREF FOR FILE #601.21 ; 12/28/04
+YSXRAC6 ; COMPILED XREF FOR FILE #601.21 ; 04/07/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC7.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC7.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC7.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC7 ; COMPILED XREF FOR FILE #601.22 ; 12/28/04
+YSXRAC7 ; COMPILED XREF FOR FILE #601.22 ; 04/07/05
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
@@ -11,5 +11,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" D SET^YTCROSS
-CR1 S DIXR=476
+CR1 S DIXR=491
  K X
  S X(1)=$P(DIKZ(0),U,1)
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC8.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC8.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAC8.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAC8 ; COMPILED XREF FOR FILE #601.2213 ; 12/28/04
+YSXRAC8 ; COMPILED XREF FOR FILE #601.2213 ; 04/07/05
  ; 
  S DA(3)=DA(2) S DA(2)=0 S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAD ; DRIVER FOR COMPILED XREFS FOR FILE #601.3 ; 10/15/04
+YSXRAD ; DRIVER FOR COMPILED XREFS FOR FILE #601.3 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAD1 ; COMPILED XREF FOR FILE #601.3 ; 10/15/04
+YSXRAD1 ; COMPILED XREF FOR FILE #601.3 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAD2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAD2 ; COMPILED XREF FOR FILE #601.3 ; 10/15/04
+YSXRAD2 ; COMPILED XREF FOR FILE #601.3 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAE ; DRIVER FOR COMPILED XREFS FOR FILE #601.4 ; 10/15/04
+YSXRAE ; DRIVER FOR COMPILED XREFS FOR FILE #601.4 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAE1 ; COMPILED XREF FOR FILE #601.4 ; 10/15/04
+YSXRAE1 ; COMPILED XREF FOR FILE #601.4 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAE2 ; COMPILED XREF FOR FILE #601.41 ; 10/15/04
+YSXRAE2 ; COMPILED XREF FOR FILE #601.41 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAE3 ; COMPILED XREF FOR FILE #601.4 ; 10/15/04
+YSXRAE3 ; COMPILED XREF FOR FILE #601.4 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAE4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAE4 ; COMPILED XREF FOR FILE #601.41 ; 10/15/04
+YSXRAE4 ; COMPILED XREF FOR FILE #601.41 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF ; DRIVER FOR COMPILED XREFS FOR FILE #602 ; 10/15/04
+YSXRAF ; DRIVER FOR COMPILED XREFS FOR FILE #602 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF1 ; COMPILED XREF FOR FILE #602 ; 10/15/04
+YSXRAF1 ; COMPILED XREF FOR FILE #602 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF2 ; COMPILED XREF FOR FILE #602.01 ; 10/15/04
+YSXRAF2 ; COMPILED XREF FOR FILE #602.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF3 ; COMPILED XREF FOR FILE #602.015 ; 10/15/04
+YSXRAF3 ; COMPILED XREF FOR FILE #602.015 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF4 ; COMPILED XREF FOR FILE #602 ; 10/15/04
+YSXRAF4 ; COMPILED XREF FOR FILE #602 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF5.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF5 ; COMPILED XREF FOR FILE #602.01 ; 10/15/04
+YSXRAF5 ; COMPILED XREF FOR FILE #602.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF6.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF6.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAF6.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAF6 ; COMPILED XREF FOR FILE #602.015 ; 10/15/04
+YSXRAF6 ; COMPILED XREF FOR FILE #602.015 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAG ; DRIVER FOR COMPILED XREFS FOR FILE #605 ; 10/15/04
+YSXRAG ; DRIVER FOR COMPILED XREFS FOR FILE #605 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAG1 ; COMPILED XREF FOR FILE #605 ; 10/15/04
+YSXRAG1 ; COMPILED XREF FOR FILE #605 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAG2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAG2 ; COMPILED XREF FOR FILE #605 ; 10/15/04
+YSXRAG2 ; COMPILED XREF FOR FILE #605 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAJ ; DRIVER FOR COMPILED XREFS FOR FILE #615 ; 10/15/04
+YSXRAJ ; DRIVER FOR COMPILED XREFS FOR FILE #615 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAJ1 ; COMPILED XREF FOR FILE #615 ; 10/15/04
+YSXRAJ1 ; COMPILED XREF FOR FILE #615 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAJ2 ; COMPILED XREF FOR FILE #615.01 ; 10/15/04
+YSXRAJ2 ; COMPILED XREF FOR FILE #615.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAJ3 ; COMPILED XREF FOR FILE #615 ; 10/15/04
+YSXRAJ3 ; COMPILED XREF FOR FILE #615 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAJ4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAJ4 ; COMPILED XREF FOR FILE #615.01 ; 10/15/04
+YSXRAJ4 ; COMPILED XREF FOR FILE #615.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK ; DRIVER FOR COMPILED XREFS FOR FILE #615.2 ; 10/15/04
+YSXRAK ; DRIVER FOR COMPILED XREFS FOR FILE #615.2 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK1 ; COMPILED XREF FOR FILE #615.2 ; 10/15/04
+YSXRAK1 ; COMPILED XREF FOR FILE #615.2 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK10.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK10.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK10.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK10 ; COMPILED XREF FOR FILE #615.24 ; 10/15/04
+YSXRAK10 ; COMPILED XREF FOR FILE #615.24 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK11.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK11.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK11.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK11 ; COMPILED XREF FOR FILE #615.34 ; 10/15/04
+YSXRAK11 ; COMPILED XREF FOR FILE #615.34 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK12.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK12.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK12.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK12 ; COMPILED XREF FOR FILE #615.35 ; 10/15/04
+YSXRAK12 ; COMPILED XREF FOR FILE #615.35 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK2 ; COMPILED XREF FOR FILE #615.21 ; 10/15/04
+YSXRAK2 ; COMPILED XREF FOR FILE #615.21 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK3 ; COMPILED XREF FOR FILE #615.23 ; 10/15/04
+YSXRAK3 ; COMPILED XREF FOR FILE #615.23 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK4 ; COMPILED XREF FOR FILE #615.24 ; 10/15/04
+YSXRAK4 ; COMPILED XREF FOR FILE #615.24 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK5.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK5 ; COMPILED XREF FOR FILE #615.34 ; 10/15/04
+YSXRAK5 ; COMPILED XREF FOR FILE #615.34 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK6.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK6.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK6.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK6 ; COMPILED XREF FOR FILE #615.35 ; 10/15/04
+YSXRAK6 ; COMPILED XREF FOR FILE #615.35 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK7.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK7.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK7.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK7 ; COMPILED XREF FOR FILE #615.2 ; 10/15/04
+YSXRAK7 ; COMPILED XREF FOR FILE #615.2 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK8.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK8.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK8.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK8 ; COMPILED XREF FOR FILE #615.21 ; 10/15/04
+YSXRAK8 ; COMPILED XREF FOR FILE #615.21 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK9.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK9.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAK9.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAK9 ; COMPILED XREF FOR FILE #615.23 ; 10/15/04
+YSXRAK9 ; COMPILED XREF FOR FILE #615.23 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAL ; DRIVER FOR COMPILED XREFS FOR FILE #615.5 ; 10/15/04
+YSXRAL ; DRIVER FOR COMPILED XREFS FOR FILE #615.5 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAL1 ; COMPILED XREF FOR FILE #615.5 ; 10/15/04
+YSXRAL1 ; COMPILED XREF FOR FILE #615.5 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAL2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAL2 ; COMPILED XREF FOR FILE #615.5 ; 10/15/04
+YSXRAL2 ; COMPILED XREF FOR FILE #615.5 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAM ; DRIVER FOR COMPILED XREFS FOR FILE #615.6 ; 10/15/04
+YSXRAM ; DRIVER FOR COMPILED XREFS FOR FILE #615.6 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAM1 ; COMPILED XREF FOR FILE #615.6 ; 10/15/04
+YSXRAM1 ; COMPILED XREF FOR FILE #615.6 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAM2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAM2 ; COMPILED XREF FOR FILE #615.6 ; 10/15/04
+YSXRAM2 ; COMPILED XREF FOR FILE #615.6 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAN ; DRIVER FOR COMPILED XREFS FOR FILE #615.7 ; 10/15/04
+YSXRAN ; DRIVER FOR COMPILED XREFS FOR FILE #615.7 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAN1 ; COMPILED XREF FOR FILE #615.7 ; 10/15/04
+YSXRAN1 ; COMPILED XREF FOR FILE #615.7 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAN2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAN2 ; COMPILED XREF FOR FILE #615.7 ; 10/15/04
+YSXRAN2 ; COMPILED XREF FOR FILE #615.7 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAO ; DRIVER FOR COMPILED XREFS FOR FILE #615.8 ; 10/15/04
+YSXRAO ; DRIVER FOR COMPILED XREFS FOR FILE #615.8 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAO1 ; COMPILED XREF FOR FILE #615.8 ; 10/15/04
+YSXRAO1 ; COMPILED XREF FOR FILE #615.8 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAO2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAO2 ; COMPILED XREF FOR FILE #615.8 ; 10/15/04
+YSXRAO2 ; COMPILED XREF FOR FILE #615.8 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAP ; DRIVER FOR COMPILED XREFS FOR FILE #615.9 ; 10/15/04
+YSXRAP ; DRIVER FOR COMPILED XREFS FOR FILE #615.9 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAP1 ; COMPILED XREF FOR FILE #615.9 ; 10/15/04
+YSXRAP1 ; COMPILED XREF FOR FILE #615.9 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAP2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAP2 ; COMPILED XREF FOR FILE #615.9 ; 10/15/04
+YSXRAP2 ; COMPILED XREF FOR FILE #615.9 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAQ ; DRIVER FOR COMPILED XREFS FOR FILE #617 ; 10/15/04
+YSXRAQ ; DRIVER FOR COMPILED XREFS FOR FILE #617 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAQ1 ; COMPILED XREF FOR FILE #617 ; 10/15/04
+YSXRAQ1 ; COMPILED XREF FOR FILE #617 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAQ2 ; COMPILED XREF FOR FILE #617.01 ; 10/15/04
+YSXRAQ2 ; COMPILED XREF FOR FILE #617.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAQ3 ; COMPILED XREF FOR FILE #617 ; 10/15/04
+YSXRAQ3 ; COMPILED XREF FOR FILE #617 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAQ4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAQ4 ; COMPILED XREF FOR FILE #617.01 ; 10/15/04
+YSXRAQ4 ; COMPILED XREF FOR FILE #617.01 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAR ; DRIVER FOR COMPILED XREFS FOR FILE #618 ; 10/15/04
+YSXRAR ; DRIVER FOR COMPILED XREFS FOR FILE #618 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAR1 ; COMPILED XREF FOR FILE #618 ; 10/15/04
+YSXRAR1 ; COMPILED XREF FOR FILE #618 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAR2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAR2 ; COMPILED XREF FOR FILE #618 ; 10/15/04
+YSXRAR2 ; COMPILED XREF FOR FILE #618 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAS ; DRIVER FOR COMPILED XREFS FOR FILE #618.2 ; 10/15/04
+YSXRAS ; DRIVER FOR COMPILED XREFS FOR FILE #618.2 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAS1 ; COMPILED XREF FOR FILE #618.2 ; 10/15/04
+YSXRAS1 ; COMPILED XREF FOR FILE #618.2 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAS2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAS2 ; COMPILED XREF FOR FILE #618.2 ; 10/15/04
+YSXRAS2 ; COMPILED XREF FOR FILE #618.2 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT ; DRIVER FOR COMPILED XREFS FOR FILE #618.4 ; 10/15/04
+YSXRAT ; DRIVER FOR COMPILED XREFS FOR FILE #618.4 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT1 ; COMPILED XREF FOR FILE #618.4 ; 10/15/04
+YSXRAT1 ; COMPILED XREF FOR FILE #618.4 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT2 ; COMPILED XREF FOR FILE #618.418 ; 10/15/04
+YSXRAT2 ; COMPILED XREF FOR FILE #618.418 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT3 ; COMPILED XREF FOR FILE #618.419 ; 10/15/04
+YSXRAT3 ; COMPILED XREF FOR FILE #618.419 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT4 ; COMPILED XREF FOR FILE #618.4 ; 10/15/04
+YSXRAT4 ; COMPILED XREF FOR FILE #618.4 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT5.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT5 ; COMPILED XREF FOR FILE #618.418 ; 10/15/04
+YSXRAT5 ; COMPILED XREF FOR FILE #618.418 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT6.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT6.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAT6.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAT6 ; COMPILED XREF FOR FILE #618.419 ; 10/15/04
+YSXRAT6 ; COMPILED XREF FOR FILE #618.419 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAU ; DRIVER FOR COMPILED XREFS FOR FILE #620 ; 10/15/04
+YSXRAU ; DRIVER FOR COMPILED XREFS FOR FILE #620 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAU1 ; COMPILED XREF FOR FILE #620 ; 10/15/04
+YSXRAU1 ; COMPILED XREF FOR FILE #620 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAU2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAU2 ; COMPILED XREF FOR FILE #620 ; 10/15/04
+YSXRAU2 ; COMPILED XREF FOR FILE #620 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAV ; DRIVER FOR COMPILED XREFS FOR FILE #625 ; 10/15/04
+YSXRAV ; DRIVER FOR COMPILED XREFS FOR FILE #625 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAV1 ; COMPILED XREF FOR FILE #625 ; 10/15/04
+YSXRAV1 ; COMPILED XREF FOR FILE #625 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAV2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAV2 ; COMPILED XREF FOR FILE #625 ; 10/15/04
+YSXRAV2 ; COMPILED XREF FOR FILE #625 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAW ; DRIVER FOR COMPILED XREFS FOR FILE #627 ; 10/15/04
+YSXRAW ; DRIVER FOR COMPILED XREFS FOR FILE #627 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAW1 ; COMPILED XREF FOR FILE #627 ; 10/15/04
+YSXRAW1 ; COMPILED XREF FOR FILE #627 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAW2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAW2 ; COMPILED XREF FOR FILE #627 ; 10/15/04
+YSXRAW2 ; COMPILED XREF FOR FILE #627 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAX ; DRIVER FOR COMPILED XREFS FOR FILE #627.5 ; 10/15/04
+YSXRAX ; DRIVER FOR COMPILED XREFS FOR FILE #627.5 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAX1 ; COMPILED XREF FOR FILE #627.5 ; 10/15/04
+YSXRAX1 ; COMPILED XREF FOR FILE #627.5 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAX2 ; COMPILED XREF FOR FILE #627.51 ; 10/15/04
+YSXRAX2 ; COMPILED XREF FOR FILE #627.51 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAX3 ; COMPILED XREF FOR FILE #627.5 ; 10/15/04
+YSXRAX3 ; COMPILED XREF FOR FILE #627.5 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAX4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAX4 ; COMPILED XREF FOR FILE #627.51 ; 10/15/04
+YSXRAX4 ; COMPILED XREF FOR FILE #627.51 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAY ; DRIVER FOR COMPILED XREFS FOR FILE #627.8 ; 10/15/04
+YSXRAY ; DRIVER FOR COMPILED XREFS FOR FILE #627.8 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAY1 ; COMPILED XREF FOR FILE #627.8 ; 10/15/04
+YSXRAY1 ; COMPILED XREF FOR FILE #627.8 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAY2 ; COMPILED XREF FOR FILE #627.82 ; 10/15/04
+YSXRAY2 ; COMPILED XREF FOR FILE #627.82 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAY3 ; COMPILED XREF FOR FILE #627.8 ; 10/15/04
+YSXRAY3 ; COMPILED XREF FOR FILE #627.8 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAY4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAY4 ; COMPILED XREF FOR FILE #627.82 ; 10/15/04
+YSXRAY4 ; COMPILED XREF FOR FILE #627.82 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ ; DRIVER FOR COMPILED XREFS FOR FILE #627.9 ; 10/15/04
+YSXRAZ ; DRIVER FOR COMPILED XREFS FOR FILE #627.9 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ1 ; COMPILED XREF FOR FILE #627.9 ; 10/15/04
+YSXRAZ1 ; COMPILED XREF FOR FILE #627.9 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ2 ; COMPILED XREF FOR FILE #627.904 ; 10/15/04
+YSXRAZ2 ; COMPILED XREF FOR FILE #627.904 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ3 ; COMPILED XREF FOR FILE #627.92 ; 10/15/04
+YSXRAZ3 ; COMPILED XREF FOR FILE #627.92 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ4 ; COMPILED XREF FOR FILE #627.9 ; 10/15/04
+YSXRAZ4 ; COMPILED XREF FOR FILE #627.9 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ5.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ5 ; COMPILED XREF FOR FILE #627.904 ; 10/15/04
+YSXRAZ5 ; COMPILED XREF FOR FILE #627.904 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ6.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ6.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRAZ6.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRAZ6 ; COMPILED XREF FOR FILE #627.92 ; 10/15/04
+YSXRAZ6 ; COMPILED XREF FOR FILE #627.92 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA ; DRIVER FOR COMPILED XREFS FOR FILE #628 ; 10/15/04
+YSXRBA ; DRIVER FOR COMPILED XREFS FOR FILE #628 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA1.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA1.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA1.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA1 ; COMPILED XREF FOR FILE #628 ; 10/15/04
+YSXRBA1 ; COMPILED XREF FOR FILE #628 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA2.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA2.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA2.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA2 ; COMPILED XREF FOR FILE #628.02 ; 10/15/04
+YSXRBA2 ; COMPILED XREF FOR FILE #628.02 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA3.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA3.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA3.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA3 ; COMPILED XREF FOR FILE #628.23 ; 10/15/04
+YSXRBA3 ; COMPILED XREF FOR FILE #628.23 ; 01/30/05
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA4.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA4.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA4.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA4 ; COMPILED XREF FOR FILE #628 ; 10/15/04
+YSXRBA4 ; COMPILED XREF FOR FILE #628 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA5.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA5 ; COMPILED XREF FOR FILE #628.02 ; 10/15/04
+YSXRBA5 ; COMPILED XREF FOR FILE #628.02 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA6.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA6.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YSXRBA6.m	(revision 636)
@@ -1,3 +1,3 @@
-YSXRBA6 ; COMPILED XREF FOR FILE #628.23 ; 10/15/04
+YSXRBA6 ; COMPILED XREF FOR FILE #628.23 ; 01/30/05
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAPI5.m	(revision 636)
@@ -1,9 +1,9 @@
-YTAPI5 ;ALB/ASF- MH API NOTES ; 7/24/07 4:11pm
- ;;5.01;MENTAL HEALTH;**62,85**;Dec 30, 1994;Build 48
+YTAPI5 ;ALB/ASF- MH API NOTES ;3/17/00  14:54
+ ;;5.01;MENTAL HEALTH;**62**;Dec 30, 1994
  Q
 OUTNOTE(YSDATA) ;
  N G,I,N,P,R,X,Y,YS2,YSADATE,YSCODE,YSGG,YSGG1,YSGG2,YSJ,YSJJ,YSNCODE,YSSET,YSSR,YSST,YSX1,YSX2,YSX3,YIN,YSINN,YSINE,YSMC
  I $G(YSDATA(1))?1"[ERROR".E Q  ;---->
- I '$D(YSDATA(5)) S YSDATA(1)="[ERROR]",YSDATA(2)="bad ysdata to outnote" Q  ;--->
+ I '$D(YSDATA(5)) S YSDATA(1)="ERROR]",YSDATA(2)="bad ysdata to outnote" Q  ;--->
  S YS2=$G(YSDATA(2))
  S YSCODE=$P(YS2,U,2)
@@ -16,5 +16,5 @@
  S YSST=$P(YSDATA(6),U,4)
  S Y=$G(^YTT(601.6,YSNCODE,2))
- I Y="" S YSDATA(1)="[ERROR]",YSDATA(2)="no mh mult outcome code" Q  ;--->
+ I Y="" S YSDATA(1)="[ERROR"],YSDATA(2)="no mh mult outcome code" Q  ;--->
  ;
  X Y
@@ -68,14 +68,4 @@
  N YSCODE,YSET
  S YSCODE=$G(YS("CODE"),-1)
- ;ASF 03/08/06
- I (YSCODE="GAF")!(YSCODE="ASI") S YSDATA(1)="[DATA]",YSDATA(2)="1^exempt test" Q  ;-->out test exempt
- I $D(^YTT(601.71,"B",YSCODE)) D  Q  ;--> out
- . S YSET=$O(^YTT(601.71,"B",YSCODE,0))
- . S YSDATA(1)="[DATA]"
- . S YSKEY=$$GET1^DIQ(601.71,YSET_",",9)
- . I YSKEY="" S YSDATA(2)="1^exempt test" Q  ;-->out
- . I $D(^XUSEC(YSKEY,DUZ)) S YSDATA(2)="1^user privileged" Q  ;-->out has key
- . S YSDATA(2)="0^no access" Q  ;->out
- ;
  I '$D(^YTT(601,"B",YSCODE)) S YSDATA(1)="[ERROR]",YSDATA(2)="BAD TEST CODE" Q  ;--> out
  S YSET=$O(^YTT(601,"B",YSCODE,0))
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTAUIRR.m	(revision 636)
@@ -1,4 +1,4 @@
-YTAUIRR ;ALB/ASF-   AUI-R REPORT ;11/15/90  16:58 ; 4/6/07 4:12pm
- ;;5.01;MENTAL HEALTH;**37,85**;Dec 30, 1994;Build 48
+YTAUIRR ;ALB/ASF-   AUI-R REPORT ;11/15/90  16:58 ;
+ ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
 F0 ;
  S R="",J=1
@@ -23,5 +23,4 @@
  S S=S_$P(^YTT(601,7,"S",J,"M"),U,A+2-L1)_"^",J=J+1 G LK
 REPT ;
- Q:YSTY["X"  ;--> out ASF 09/15/04
  S X1="",$P(X1,"# ",60)=""
  S X=$P(^YTT(601,YSTEST,"P"),U),A=$P(^("P"),U,2),B=$P(^("P"),U,3),L1=58-A\2,L2=L1+A+4 S:A<9 A=9
@@ -54,12 +53,6 @@
  W @IOF Q
 DTA ;
- D KVAR^VADPT S DFN=YSDFN
- D DEM^VADPT,PID^VADPT
- S YSNM=VADM(1),YSSEX=$P(VADM(5),U),YSDOB=$P(VADM(3),U,2),YSAGE=VADM(4),YSSSN=VA("PID"),YSBID=VA("BID")
- D KVAR^VADPT
  S X0=^YTD(601.2,YSDFN,1,YSET,1,YSED,0),YSDTA=$P(X0,U,5) S:YSDTA'="" YSDTA=$$FMTE^XLFDT(YSDTA,"5ZD")
- S YSSX=YSSEX,YSBL="           ",YSHDR=YSSSN_"  "_YSNM_YSBL_YSBL_YSBL,YSHD=DT
  S YSHDR=$E(YSHDR,1,43)_" "_YSSEX_" AGE "_$J(YSAGE,2,0)_" "_YSDT(0)_" "_$$FMTE^XLFDT(YSHD,"5ZD") W @IOF,YSHDR," ",YSDTA
- S X=$P(^YTT(601,YSTEST,"P"),U)
  W ! S X7=$P(X0,U),X8=$P(X0,U,8) I X8,X8<X7 W "Begun: ",$$FMTE^XLFDT(X8,"5ZD"),"  Finished ",$$FMTE^XLFDT(X7,"5ZD")
  W ?53,"PRINTED  ENTERED  " W:YSDTA'="" "ADMIN" Q
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTDOMR.m	(revision 636)
@@ -1,4 +1,4 @@
-YTDOMR ;ALB/ASF-DEPRESSION OUTCOME MODULE REPORT ; 5/7/07 10:39am
- ;;5.01;MENTAL HEALTH;**31,85**;Dec 30, 1994;Build 48
+YTDOMR ;ALB/ASF-DEPRESSION OUTCOME MODULE REPORT ;2/23/99  15:09
+ ;;5.01;MENTAL HEALTH;**31**;Dec 30, 1994
 EN81 ;
  D ^YTDOMR1
@@ -78,8 +78,7 @@
  W !,"Felt fearful: " S YSI=3 D ENGQ
  W !,"Sleep was restless: " S YSI=4 D ENGQ
- W !,"Felt hopeless about the future: " S YSI=5 D ENGQ
+ W !,"Felt hopeful about the future: " S YSI=5 D ENGQ
  S X=^YTD(601.2,YSDFN,1,YSET,1,YSED,1)
- S (YSMISS,YSDEP)=0 F I=1:1:4 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1 ; ASF 10/20/06
- S:$E(X,5)?1N YSDEP=YSDEP+(3-$E(X,5)) S:$E(X,5)="X" YSMISS=YSMISS+1
+ S (YSMISS,YSDEP)=0 F I=1:1:5 S YSDEP=YSDEP+$E(X,I) S:$E(X,I)="X" YSMISS=YSMISS+1
  I YSMISS=1 S YSDEP=YSDEP+(YSDEP/4)
  I YSMISS>1 W !!,"The validity of this test is compromised as "_YSMISS_" of the 5 questions",!,"were not answered." Q
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTKIL.m	(revision 636)
@@ -1,13 +1,9 @@
-YTKIL ;SLC/TGA-KILL TEST/INTERVIEW DATA ;4/21/92  08:50 ; 10/31/07 12:41pm
- ;;5.01;MENTAL HEALTH;**37,85**;Dec 30, 1994;Build 48
+YTKIL ;SLC/TGA-KILL TEST/INTERVIEW DATA ;4/21/92  08:50 ;03/11/94 12:49
+ ;;5.01;MENTAL HEALTH;**37**;Dec 30, 1994
  ;
  ; Called from the top by MENU option YSMKIL
  ;
  S YSO=0,YSNOKILL=1 W @IOF,!!,"Delete Patient Data"
- W ! D ^YSLRP G:YSDFN<1 END
- S DIR(0)="Y",DIR("A")="Delete MHA3 data",DIR("B")="No" D ^DIR
- Q:$G(DIRUT)
- IF Y D EN^YTQKIL Q  ;-->out
- I '$D(^YTD(601.2,YSDFN)),'$D(^YTD(601.4,YSDFN)) W !!,"NO DATA ON THIS PATIENT!" G END
+ W ! D ^YSLRP G:YSDFN<1 END I '$D(^YTD(601.2,YSDFN)),'$D(^YTD(601.4,YSDFN)) W !!,"NO DATA ON THIS PATIENT!" G END
 R ;
  R !!,"Delete All tests and interviews? N// ",A:DTIME S YSTOUT='$T,YSUOUT=A["^" G:YSTOUT!YSUOUT END S A=$TR($E(A_"N"),"yn","YN") I "YN"'[A W:A'["?" " ?",$C(7) G R
Index: FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m
===================================================================
--- FOIAVistA/trunk/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m	(revision 631)
+++ FOIAVistA/tag/r/MENTAL_HEALTH-YS-RUCL-YI-YT/YTPCL.m	(revision 636)
@@ -1,4 +1,4 @@
-YTPCL ;ALB/ASF TEST-PTST CHECKLISTS ; 4/5/07 10:05am
- ;;5.01;MENTAL HEALTH;**66,85**;Dec 30, 1994;Build 48
+YTPCL ;ALB/ASF TEST-PTST CHECKLISTS ;7/19/00  11:11
+ ;;5.01;MENTAL HEALTH;**66**;Dec 30, 1994
  ;
  ;Reference to ^DIR supported by IA #10026
@@ -18,11 +18,5 @@
  W !!
  I IOST?1"C".E W ! S DIR(0)="E" D ^DIR Q:Y'=1
- W !!!,"Items"
- F I=1:1:17 D
- . W !,I,". ",^YTT(601,YSET,"Q",I,"T",1,0)
- . I $D(^YTT(601,YSET,"Q",I,"T",2,0)) W:^(0)'=" " !?7,^(0)
- . I I=5 W !?7,^YTT(601,YSET,"Q",I,"T",3,0)
- . W " :",$E(^YTD(601.2,YSDFN,1,YSET,1,YSED,1),I)
- W !!,"1= Not at all 2= A little bit 3= Moderately 4= Quite a bit 5= Extremely"
+ D IR^YTREPT
  Q
 SPTSD ;SCREENING REPORT
Index: FOIAVistA/tag/r/NATIONAL_DRUG_FILE-PSN/PSNHFRM.m
===================================================================
--- FOIAVistA/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNHFRM.m	(revision 631)
+++ FOIAVistA/tag/r/NATIONAL_DRUG_FILE-PSN/PSNHFRM.m	(revision 636)
@@ -1,4 +1,4 @@
-PSNHFRM ;BIR/WRT-Report of Hospital Formulary drugs from DRUG file ; 8/28/07 12:07pm
- ;;4.0; NATIONAL DRUG FILE;**152**;30 Oct 98;Build 5
+PSNHFRM ;BIR/WRT-Report of Hospital Formulary drugs from DRUG file ; 10/18/98 17:48
+ ;;4.0; NATIONAL DRUG FILE;; 30 Oct 98
 DVC K IO("Q"),%ZIS,POP,IOP S %ZIS="QM",%ZIS("B")="",%ZIS("A")="DEVICE: " D ^%ZIS G:POP DONE W:$E(IOST)'="P" !!,"This report must be run on a printer.",!! G:$E(IOST)'="P" DVC I POP K IOP,POP,IO("Q") Q
 QUEUE I $D(IO("Q")) K IO("Q") S ZTRTN="ENQ^PSNHFRM" K ZTSAVE,ZTDTH,ZTSK S PSNDEV=ION_";"_IOST_";"_IOM_";"_IOSL,ZTSAVE("SF")="",ZTSAVE("PSNDEV")="",ZTSAVE("PSNANS")="",ZTDESC="Hospital Formulary Report",ZTIO=""
@@ -22,8 +22,5 @@
 QUEUE1 S IOP=PSNDEV F  D ^%ZIS Q:'POP  H 20
  Q
-LOOP F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB  D
- .Q:'$D(^PSDRUG(PSNB,0))
- .S PSNAME=$P(^PSDRUG(PSNB,0),"^",1) Q:PSNAME=""
- .S PSNCLSS=$P(^PSDRUG(PSNB,0),"^",2) S:PSNCLSS']"" PSNCLSS="No Class" I $P(^PSDRUG(PSNB,0),"^",9)'=1 D CHECK
+LOOP F PSNB=0:0 S PSNB=$O(^PSDRUG(PSNB)) Q:'PSNB  S PSNAME=$P(^PSDRUG(PSNB,0),"^",1),PSNCLSS=$P(^PSDRUG(PSNB,0),"^",2) S:PSNCLSS']"" PSNCLSS="No Class" I $P(^PSDRUG(PSNB,0),"^",9)'=1 D CHECK
  Q
 GETDATE I '$D(^PSDRUG(PSNB,"I")) D GETNODE,GETPRIC
@@ -44,5 +41,5 @@
 TRADE1 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=1 S PSNTRD="ZZXZZXZZX" S PSNAR(3,PSNAME,"ZZXZZXZZX")=""
  Q
-TRADE2 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=0 S PSNTRD=$P(^PSDRUG(PSNB,1,PSNUM,0),"^",1) I PSNTRD]"" S PSNAR(1,PSNAME,PSNTRD)=""
+TRADE2 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)=0 S PSNTRD=$P(^PSDRUG(PSNB,1,PSNUM,0),"^",1) S PSNAR(1,PSNAME,PSNTRD)=""
  Q
 TRADE3 I $P(^PSDRUG(PSNB,1,PSNUM,0),"^",3)="" S PSNTRD="ZZXZZXZZX" S PSNAR(2,PSNAME,"ZZXZZXZZX")=""
Index: FOIAVistA/tag/r/NATIONAL_DRUG_FILE-PSN/PSNPPIP.m
===================================================================
--- FOIAVistA/trunk/r/NATIONAL_DRUG_FILE-PSN/PSNPPIP.m	(revision 631)
+++ FOIAVistA/tag/r/NATIONAL_DRUG_FILE-PSN/PSNPPIP.m	(revision 636)
@@ -1,4 +1,4 @@
-PSNPPIP ;BIR/DMA-WRT-print a medication instruction sheet ; 12 Apr 2007  8:38 AM
- ;;4.0; NATIONAL DRUG FILE;**3,7,30,62,84,141**; 30 Oct 98;Build 3
+PSNPPIP ;BIR/DMA-WRT-print a medication instruction sheet ; 02/12/03 16:46
+ ;;4.0; NATIONAL DRUG FILE;**3,7,30,62,84**; 30 Oct 98
  ;
  ; Reference to ^PS(59.7 supported by IA #2613
@@ -160,5 +160,5 @@
  I PG>1,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR I 'Y S QUIT=1 Q
  ; W:$Y @IOF W !!,LIN0,$S(PSNTYPE<4:"Medication instructions for ",1:"Informaci"_$C(243)_"n sobre su medicina "),DRUG,?70,$S(PSNTYPE<4:"Page ",1:"P"_$C(225)_"gina "),PG S PG=PG+1
- W:$Y @IOF W !!,?70,$S(PSNTYPE<4:"Page ",1:"P"_$C(160)_"gina "),PG,!,LIN0,$S(PSNTYPE<4:"Medication instructions for ",1:"Informaci"_$C(162)_"n sobre su medicin a  "),DRUG S PG=PG+1
+ W:$Y @IOF W !!,?70,$S(PSNTYPE<4:"Page ",1:"P"_$C(225)_"gina "),PG,!,LIN0,$S(PSNTYPE<4:"Medication instructions for ",1:"Informaci"_$C(243)_"n sobre su medicin a  "),DRUG S PG=PG+1
  I $D(NAM) W !!,?2,"Printed for: ",NAM_" ("_VA("BID")_")",?60,$$HTE^XLFDT(+$H),!,?2,"Rx Number:   "_$G(PSRX)
  W !!! Q
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOW1.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOW1.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOW1.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOW1 ; GENERATED FROM 'ONCOW1' PRINT TEMPLATE (#874) ; 03/11/05 ; (FILE 165.5, MARGIN=132)
+ONCOW1 ; GENERATED FROM 'ONCOW1' PRINT TEMPLATE (#874) ; 04/11/05 ; (FILE 165.5, MARGIN=132)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOX2.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOX2.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOX2.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOX2 ; GENERATED FROM 'ONCOX2' PRINT TEMPLATE (#843) ; 03/11/05 ; (FILE 165.5, MARGIN=132)
+ONCOX2 ; GENERATED FROM 'ONCOX2' PRINT TEMPLATE (#843) ; 04/11/05 ; (FILE 165.5, MARGIN=132)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOX7.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOX7.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOX7.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOX7 ; GENERATED FROM 'ONCOX7' PRINT TEMPLATE (#848) ; 03/11/05 ; (FILE 165.5, MARGIN=132)
+ONCOX7 ; GENERATED FROM 'ONCOX7' PRINT TEMPLATE (#848) ; 04/11/05 ; (FILE 165.5, MARGIN=132)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXA2.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXA2.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXA2.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXA2 ; GENERATED FROM 'ONCOXA2' PRINT TEMPLATE (#828) ; 03/11/05 ; (FILE 165.5, MARGIN=80)
+ONCOXA2 ; GENERATED FROM 'ONCOXA2' PRINT TEMPLATE (#828) ; 04/11/05 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXA3.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXA3.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXA3.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXA3 ; GENERATED FROM 'ONCOXA3' PRINT TEMPLATE (#829) ; 03/11/05 ; (FILE 165.5, MARGIN=80)
+ONCOXA3 ; GENERATED FROM 'ONCOXA3' PRINT TEMPLATE (#829) ; 04/11/05 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXDI.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXDI.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXDI.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXDI ; GENERATED FROM 'ONCO XDEATH INFO' PRINT TEMPLATE (#788) ; 08/13/05 ; (FILE 160, MARGIN=80)
+ONCOXDI ; GENERATED FROM 'ONCO XDEATH INFO' PRINT TEMPLATE (#788) ; 04/11/06 ; (FILE 160, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXP1.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXP1.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXP1.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXP1 ; GENERATED FROM 'ONCO XPATIENT DATA' PRINT TEMPLATE (#774) ; 03/11/05 ; (FILE 160, MARGIN=80)
+ONCOXP1 ; GENERATED FROM 'ONCO XPATIENT DATA' PRINT TEMPLATE (#774) ; 04/11/05 ; (FILE 160, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXPU.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXPU.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXPU.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXPU ; GENERATED FROM 'ONCO XPATIENT STATUS' PRINT TEMPLATE (#1340) ; 05/26/06 ; (FILE 160, MARGIN=80)
+ONCOXPU ; GENERATED FROM 'ONCO XPATIENT STATUS' PRINT TEMPLATE (#1340) ; 10/08/06 ; (FILE 160, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXS1.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXS1.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXS1.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXS1 ; GENERATED FROM 'ONCO XADMISSION' PRINT TEMPLATE (#835) ; 08/13/05 ; (FILE 165.5, MARGIN=80)
+ONCOXS1 ; GENERATED FROM 'ONCO XADMISSION' PRINT TEMPLATE (#835) ; 04/11/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXU.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOXU.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOXU.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOXU ; GENERATED FROM 'ONCO XABSTRACT RECORD' PRINT TEMPLATE (#826) ; 09/04/07 ; (FILE 165.5, MARGIN=80)
+ONCOXU ; GENERATED FROM 'ONCO XABSTRACT RECORD' PRINT TEMPLATE (#826) ; 12/27/07 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY49.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY49.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY49.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY49 ; GENERATED FROM 'ONCOY49' PRINT TEMPLATE (#817) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY49 ; GENERATED FROM 'ONCOY49' PRINT TEMPLATE (#817) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY50.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY50.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY50.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY50 ; GENERATED FROM 'ONCOY50' PRINT TEMPLATE (#860) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY50 ; GENERATED FROM 'ONCOY50' PRINT TEMPLATE (#860) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY51.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY51.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY51.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY51 ; GENERATED FROM 'ONCOY51' PRINT TEMPLATE (#861) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY51 ; GENERATED FROM 'ONCOY51' PRINT TEMPLATE (#861) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY52.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY52.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY52.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY52 ; GENERATED FROM 'ONCOY52' PRINT TEMPLATE (#862) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY52 ; GENERATED FROM 'ONCOY52' PRINT TEMPLATE (#862) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY53.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY53.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY53.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY53 ; GENERATED FROM 'ONCOY53' PRINT TEMPLATE (#863) ; 05/26/06 ; (FILE 165.5, MARGIN=80)
+ONCOY53 ; GENERATED FROM 'ONCOY53' PRINT TEMPLATE (#863) ; 10/08/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY54.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY54.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY54.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY54 ; GENERATED FROM 'ONCOY54' PRINT TEMPLATE (#812) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY54 ; GENERATED FROM 'ONCOY54' PRINT TEMPLATE (#812) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY55.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY55.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY55.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY55 ; GENERATED FROM 'ONCOY55' PRINT TEMPLATE (#813) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY55 ; GENERATED FROM 'ONCOY55' PRINT TEMPLATE (#813) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY56.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY56.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY56.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY56 ; GENERATED FROM 'ONCOY56' PRINT TEMPLATE (#814) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY56 ; GENERATED FROM 'ONCOY56' PRINT TEMPLATE (#814) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY57.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY57.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY57.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY57 ; GENERATED FROM 'ONCOY57' PRINT TEMPLATE (#815) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY57 ; GENERATED FROM 'ONCOY57' PRINT TEMPLATE (#815) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY58.m
===================================================================
--- FOIAVistA/trunk/r/ONCOLOGY-ONC/ONCOY58.m	(revision 631)
+++ FOIAVistA/tag/r/ONCOLOGY-ONC/ONCOY58.m	(revision 636)
@@ -1,3 +1,3 @@
-ONCOY58 ; GENERATED FROM 'ONCOY58' PRINT TEMPLATE (#816) ; 04/10/06 ; (FILE 165.5, MARGIN=80)
+ONCOY58 ; GENERATED FROM 'ONCOY58' PRINT TEMPLATE (#816) ; 04/21/06 ; (FILE 165.5, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMP8.m	(revision 636)
@@ -1,5 +1,13 @@
-OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;10/29/98  12:37
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+OCXOCMP8 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Assemble Order Check Routines utilities) ;6:55 PM  24 Jan 2008
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997;Build 2
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+ ;
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
  ;
  Q
@@ -10,6 +18,9 @@
  S DIE="^TMP(""OCXCMP"",$J,""D CODE"","_RNUM_",",XCN=0,X=$$RNAM(RNUM)
  X ^%ZOSF("SAVE")
- W:'$G(OCXAUTO) "  ...",XCM," lines filed."
- S OCXLCNT=$G(OCXLCNT)+XCM
+ ;
+ ; WVEHR/SO 01/24/08 ;Commented out next 2 lines
+ ; W:'$G(OCXAUTO) "  ...",XCM," lines filed."
+ ; S OCXLCNT=$G(OCXLCNT)+XCM
+ ;
  Q
  ;
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ01.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ01 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
@@ -17,5 +17,5 @@
  ;               Raw Data Logging: OFF
  ; Compiler mode:  ON
- ;   Compiled by: HARVEY,JULIE S  (DUZ=1)
+ ;   Compiled by: ORMSBY,SKIP  (DUZ=1)
  Q
  ;
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ02.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ02 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ03.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ03 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ04.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ04 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ05.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ05 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ06.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ06 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ07.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ07 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ08.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ08 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ09.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ09 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0A.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0A ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0B.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0B ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0C.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0C ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0D.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0D ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0E.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0E ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0F.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0F ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0G.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0G.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0G.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0G ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0H.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0H ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0I.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0I ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0J.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0J ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0K.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0K ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0L.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0L ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0M.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0M ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0N.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0N ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0O.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0O ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0P.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0P ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Q.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0Q ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0R.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0R ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0S.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0S ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0T.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0T ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0U.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0U ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0V.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0V ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0W.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0W ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0X.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0X ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Y.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0Y ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ0Z.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ0Z ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ10.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ10 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ11.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ11 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ12.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ12 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ13.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ13 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOZ14.m	(revision 636)
@@ -1,3 +1,3 @@
-OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;SEP 4,2007 at 23:12
+OCXOZ14 ;SLC/RJS,CLA - Order Check Scan ;DEC 27,2007 at 06:00
  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,221**;Dec 17,1997
  ;;  ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHTAB5.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHTAB5.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCHTAB5.m	(revision 636)
@@ -1,9 +1,8 @@
 ORCHTAB5 ;SLC/dcm - Add item to tab listing ;4/17/97  11:08
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25,263**;Dec 17, 1997;Build 9
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**25**;Dec 17, 1997
  ;
 MED ; -- Medicine Summary of Patient Procedures
  K ^TMP("MCAR",$J)
- ;I '$D(^MCAR(690,"AC",+ORVP)) Q
+ I '$D(^MCAR(690,"AC",+ORVP)) Q
  D EN^MCARPS2(+ORVP)
  N MCARID,J
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDIT.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDIT.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCMEDIT.m	(revision 636)
@@ -1,5 +1,4 @@
 ORCMEDIT ;SLC/MKB-Menu Editor ;4/19/01  11:27
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,263**;Dec 17, 1997;Build 9
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95**;Dec 17, 1997
 EN ; -- start here
  S ORMENU=$$MENU D:ORMENU EN^VALM("OR MENU EDITOR")
@@ -25,5 +24,5 @@
  . M ^ORD(101.41,+ORNEW,2)=^ORD(101.41,+Y,2) ; description
  . S:$D(^ORD(101.41,+Y,5)) ^ORD(101.41,+ORNEW,5)=^ORD(101.41,+Y,5)
- . S X=$P(Y(0),U,2),$P(^ORD(101.41,+ORNEW,0),U,2)=X S:X'="" ^ORD(101.41,"C",$$UP^XLFSTR(X),+ORNEW)="" ; display text
+ . S X=$P(Y(0),U,2),$P(^ORD(101.41,+ORNEW,0),U,2)=X,^ORD(101.41,"C",$$UP^XLFSTR(X),+ORNEW)="" ; display text
  . S DA(1)=+ORNEW,DIK="^ORD(101.41,"_+ORNEW_",10,",DIK(1)="2^AD" D ENALL^DIK
  I $P(ORNEW,U,3) S DA=+ORNEW,DIE="^ORD(101.41,",DR="2;20;51;52;53"_$S($G(DUZ(0))="@":";30;40",1:"") D ^DIE
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD2.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 12/11/06
+ORD2 ; DRIVER FOR COMPILED XREFS FOR FILE #100 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD21.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD21 ; COMPILED XREF FOR FILE #100 ; 12/11/06
+ORD21 ; COMPILED XREF FOR FILE #100 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD210.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD210 ; COMPILED XREF FOR FILE #100.001 ; 12/11/06
+ORD210 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD211.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD211 ; COMPILED XREF FOR FILE #100.002 ; 12/11/06
+ORD211 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD212.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD212 ; COMPILED XREF FOR FILE #100.008 ; 12/11/06
+ORD212 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD213.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD213 ; COMPILED XREF FOR FILE #100.04 ; 12/11/06
+ORD213 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD214.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD214 ; COMPILED XREF FOR FILE #100.045 ; 12/11/06
+ORD214 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD215.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD215 ; COMPILED XREF FOR FILE #100.051 ; 12/11/06
+ORD215 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD216.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD216 ; COMPILED XREF FOR FILE #100.09 ; 12/11/06
+ORD216 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD22.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD22 ; COMPILED XREF FOR FILE #100.001 ; 12/11/06
+ORD22 ; COMPILED XREF FOR FILE #100.001 ; 12/25/06
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD23.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD23 ; COMPILED XREF FOR FILE #100.002 ; 12/11/06
+ORD23 ; COMPILED XREF FOR FILE #100.002 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD24.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD24 ; COMPILED XREF FOR FILE #100.008 ; 12/11/06
+ORD24 ; COMPILED XREF FOR FILE #100.008 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD25.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD25 ; COMPILED XREF FOR FILE #100.04 ; 12/11/06
+ORD25 ; COMPILED XREF FOR FILE #100.04 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD26.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD26 ; COMPILED XREF FOR FILE #100.045 ; 12/11/06
+ORD26 ; COMPILED XREF FOR FILE #100.045 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD27.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD27 ; COMPILED XREF FOR FILE #100.051 ; 12/11/06
+ORD27 ; COMPILED XREF FOR FILE #100.051 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD28.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD28 ; COMPILED XREF FOR FILE #100.09 ; 12/11/06
+ORD28 ; COMPILED XREF FOR FILE #100.09 ; 12/25/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORD29.m	(revision 636)
@@ -1,3 +1,3 @@
-ORD29 ; COMPILED XREF FOR FILE #100 ; 12/11/06
+ORD29 ; COMPILED XREF FOR FILE #100 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORDV04.m	(revision 636)
@@ -1,4 +1,4 @@
 ORDV04 ; SLC/DAN - OE/RR ;7/21/04  15:32
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,148,160,208,195,241,215,274,256**;Dec 17,1997;Build 5
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,148,160,208,195,241,215,274**;Dec 17,1997;Build 20
  ;OE/RR COMPONENT
  ;
@@ -72,7 +72,4 @@
  ;   STATUS = "ALL" to produce all problems
  ;
- I $L($T(GCPR^OMGCOAS1)) D  Q  ; Call if FHIE station 200
- . D GCPR^OMGCOAS1(DFN,"PLL",ORDBEG,ORDEND,ORMAX)
- . S ROOT=$NA(^TMP("ORDATA",$J))
  N ORPROBNO,ORXREC0,ORLOC,I,K,X,ORSITE,SITE,ORMORE
  S ORSITE=$$SITE^VASITE,ORSITE=$P(ORSITE,"^",2)_";"_$P(ORSITE,"^",3)
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMEVNT.m	(revision 636)
@@ -1,5 +1,4 @@
 ORMEVNT ;SLC/MKB-Trigger HL7 msg off MAS events ;3/31/04  09:21
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195,278**;Dec 17, 1997;Build 5
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**24,45,70,79,141,165,177,186,195**;Dec 17, 1997
  ;
 EN1 ; -- tasked entry point
@@ -16,5 +15,5 @@
  Q:'$G(DFN)  Q:$D(DGPMPC)  Q:DGPMT=4!(DGPMT=5)
  I '$G(DGPMP) S ^XTMP("OREVENT",DFN,DGPMDA,0)=DT_U_$$FMADD^XLFDT(DT,2)_U_"Event process flag" ;195
- I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 Q  ;195 edits processed after new JEH
+ I $G(DGPMP),$D(^XTMP("OREVENT",DFN,DGPMDA)) D EN1 ;195 edits processed after new
  N XQORQUIT,XQORPOP,DTOUT,DUOUT,DIRUT,DIROUT ;protect protocol context
  N VAIP,DONE,ORVP,ORWARD,ORTS,ORL,ORDIV,ORLAST,X,Y,I,ORCURRNT,OREVENT,ORDCRULE,ORACT,ORPRINT
@@ -29,9 +28,7 @@
  S ORLAST("TS")=$$PREVTS,X=+VAIP(15,4) F I="WD","LOC","DIV" S ORLAST(I)=""
  S:X ORLAST("WD")=X,Y=+$G(^DIC(42,X,44)),ORLAST("LOC")=Y_";SC(",ORLAST("DIV")=$$DIV(Y)
- N OREVNTLK S OREVNTLK=""  ;JEH
- S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW") ; Lock
+ S ORCURRNT=$$CURRENT,OREVENT=$$PATEVT,ORACT=$S($G(DGPMP):"ED",1:"NW")
  I OREVENT=-1 D EN1 Q  ;195 Can't lock, retry
- S OREVNTLK=OREVENT  ; save routine copy of ifn JEH
- I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D   ;edited 
+ I $G(DGPMP),$D(^ORE(100.2,"ADT",DGPMDA)) D  Q:$G(DONE)  ;edited
  . N LAST,OREVT,DA,X,I S LAST=+$O(^ORE(100.2,"ADT",DGPMDA,""),-1) Q:LAST<1
  . S OREVT=+$O(^ORE(100.2,"ADT",DGPMDA,LAST,0)),DA=+$O(^(OREVT,0))
@@ -39,5 +36,4 @@
  . I $P(X,U,5)=+$G(VAIP(4)),$P(X,U,6)=+$G(VAIP(8)),$P(X,U,7)=+$G(VAIP(5)) S DONE=1 Q  ;no change
  . I 'OREVENT D ACTLOG^OREVNTX(OREVT,"ED",$$TYPE(DGPMT),1) S DONE=1
- I $G(DONE) D FINISHED Q  ; unlock and clean up before quit IFNjeh 
 B ;
  I '$G(DGPMP),ORCURRNT D  ;new mvt - autoDC
@@ -61,6 +57,5 @@
  I DGPMT=3,ORCURRNT,'$G(DGPMP) D DISCH ;lapse remaining events
  I '$G(DFN),$G(ORVP) S DFN=+ORVP ;just in case
-FINISHED  ; unlock and clean up JEH
- D:$G(OREVNTLK) UNLEVT^ORX2(OREVNTLK) K ^XTMP("OREVENT",DFN,DGPMDA) ;195
+ D:$G(OREVENT) UNLEVT^ORX2(OREVENT) K ^XTMP("OREVENT",DFN,DGPMDA) ;195
  Q
  ;
@@ -177,10 +172,10 @@
  ;
 REINST ; -- Reinstate meds from observation
- I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q   ;DBIA 3598
+ I '$L($T(ENR^PSJOERI)) K ^XTMP("ORDCOBS-"_+ORVP) Q
  N ORIDT,ORLASTDC,X0,ORIFN,PSIFN
  S ORIDT=+$O(^DGPM("ATID3",+ORVP,0)) S:DGPMT=2 ORIDT=$O(^DGPM("ATID3",+ORVP,ORIDT)) Q:ORIDT<1  S ORLASTDC=+$O(^(ORIDT,0)) ;186 If reinstating for transfer TO ASIH then skip pseudo discharge for WHILE ASIH
  Q:$G(^XTMP("ORDCOBS-"_+ORVP,"DISCHARGE"))'=ORLASTDC  S X0=$G(^(0))
  I $P(X0,U)<$$NOW^XLFDT K ^XTMP("ORDCOBS-"_+ORVP) Q  ;readmit after one hour 177
- S ORIFN=0 F  S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN))  Q:ORIFN<1  S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD)  ;DBIA 3598
+ S ORIFN=0 F  S ORIFN=+$O(^XTMP("ORDCOBS-"_+ORVP,ORIFN))  Q:ORIFN<1  S PSIFN=$G(^(ORIFN)) D:PSIFN ENR^PSJOERI(+ORVP,PSIFN,+ORWARD)
  K ^XTMP("ORDCOBS-"_+ORVP)
  Q
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORSNAST.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORSNAST.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORSNAST.m	(revision 636)
@@ -1,5 +1,4 @@
-ORSNAST ;SLC/RAF - Policy order search  ;06/25/2007
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**50,263**;Dec 17, 1997;Build 9
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ORSNAST ;SLC/RAF - Policy order search  ;10/20/00  14:10
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**50**;Dec 17, 1997
  ;
  ;this utility will allow the user to enter a date range to search
@@ -11,6 +10,6 @@
  S U="^" K ^TMP("ORNS",$J),^TMP("ORSERV",$J)
  W @IOF,!!?18,"Nature of Order or Order Status Search.",!?15,"This report is formatted for 132 column output."
- N DASH,DATE,DFN,DIR,DTOUT,DUOUT,EDATE,FORMAT,HDR,HDR1,IEN
- N LOC,LONER,ORIGVIEW,PAGE,PNM,PROV,QUIT,REF,RPDT,SDATE,SER,SERVICE,STOP,TEXT,TEXTSUB
+ N DASH,DATE,DFN,DIR,DTOUT,DUOUT,ED1,EDATE,FORMAT,HDR,HDR1,IEN
+ N LOC,LONER,ORIGVIEW,PAGE,PNM,PROV,QUIT,REF,RPDT,SD1,SDATE,SER,SERVICE,STOP,TEXT,TEXTSUB
  N SINGLE,SIGNED,SNAME,SSN,STATUS,SORT,SEARCH,SUB
  N VA,VADM,WHEN,WHO,Y
@@ -22,7 +21,21 @@
  S DIR("A")="Select "_$S(SORT=1:"Nature of order: ",1:"Order Status: ")
  D ^DIR S:+Y>0 SEARCH=+Y,SNAME=$P(Y,U,2) K DIR I $D(DTOUT)!($D(DUOUT)) G EXIT
- D SDATE I $D(DTOUT)!$D(DUOUT) G EXIT
- D EDATE I $D(DTOUT)!$D(DUOUT) G EXIT
- D CKDATE I $D(DTOUT)!$D(DUOUT) G EXIT
+SDATE ;sets DIR call to ask the user for a starting date
+ S DIR(0)="DA^::ETX"
+ S DIR("A")="Enter a starting date: "
+ S DIR("?")="Enter the date that you wish to start searching with. This date needs to be older than the ending date. For example: If you enter a start date of T-3, the Stop date should be T-2 or less. Enter an ^ to exit the option."
+ D ^DIR S:+Y>0 (SDATE,SD1)=+Y K DIR I $D(DTOUT)!($D(DUOUT)) G EXIT
+ I SDATE'["." S (SDATE,SD1)=SDATE_.2359
+ I $D(DTOUT)!$D(DUOUT) G EXIT
+EDATE ;sets DIR call to ask the user for an ending date (optional)
+ S DIR(0)="DA^::ETX"
+ S DIR("A")="Enter a ending date: "
+ S DIR("?")="Enter the date that you would like the search to end with. This date needs to be more recent than the start date. For example: If you entered a T-3 for the start date, enter a T-2 or less here. Enter an ^ to exit the option."
+ D ^DIR S:+Y>0 (EDATE,ED1)=+Y K DIR I $D(DTOUT)!($D(DUOUT)) G EXIT
+ I EDATE'["." S (EDATE,ED1)=EDATE_.0001
+ I $D(DTOUT)!$D(DUOUT) G EXIT
+SWITCH ;takes the date input from the user and does a switcheroo so the program
+ ;can work as intended
+ I EDATE'>SDATE S EDATE=SD1,SDATE=ED1
 FORMAT ;allows choice of formats for evaluation purpose
  S DIR(0)="SX^1:Detailed format;2:Columnar format"
@@ -60,26 +73,5 @@
  .D ^%ZTLOAD I $D(ZTSK) W !,?32,"REQUEST QUEUED"
  U IO D EN^ORSNAST1
- G EXIT
  ;
-SDATE ;sets DIR call to ask the user for a starting date
- S DIR(0)="DA^::ETX"
- S DIR("A")="Enter a starting date: "
- S DIR("?")="Enter the date that you wish to start searching with. This date needs to be older than the ending date. For example: If you enter a start date of T-3, the Stop date should be T-2 or less. Enter an ^ to exit the option."
- D ^DIR S:+Y>0 SDATE=+Y K DIR I $D(DTOUT)!($D(DUOUT)) Q
- I SDATE'["." S SDATE=SDATE_.0001
- Q
-EDATE ;sets DIR call to ask the user for an ending date (optional)
- S DIR(0)="DA^::ETX"
- S DIR("A")="Enter a ending date: "
- S DIR("?")="Enter the date that you would like the search to end with. This date needs to be more recent than the start date. For example: If you entered a T-3 for the start date, enter a T-2 or less here. Enter an ^ to exit the option."
- D ^DIR S:+Y>0 EDATE=+Y K DIR I $D(DTOUT)!($D(DUOUT)) Q
- I EDATE'["." S EDATE=EDATE_.2359
- Q
-CKDATE ; Make sure the end date is not older than the start date.
- I EDATE>SDATE Q
- W !!,?10,"The starting date must be older than the ending date.",!,?10,"Please re-enter start and end dates.",!!
- D SDATE I $D(DTOUT)!$D(DUOUT) Q
- D EDATE I $D(DTOUT)!$D(DUOUT) Q
- G CKDATE
 EXIT ;
  K ^TMP("ORNS",$J),^TMP("ORSERV",$J)
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDX.m	(revision 636)
@@ -1,5 +1,15 @@
-ORWDX ; SLC/KCM/REV/JLI - Order dialog utilities ;11/09/2006
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,246**;Dec 17, 1997;Build 8
- ;Per VHA Directive 2004-038, this routine should not be modified.
+ORWDX ; SLC/KCM/REV/JLI - Order dailog utilities ;4/21/07  19:18
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,195,215,269**;Dec 17, 1997;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+NXT() ; -- Gets index in array
+ S ILST=ILST+1
+ Q ILST
  ;
 ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items
@@ -33,9 +43,23 @@
  ;         X123456;1      = change order,  134      = quick dialog
  N I,J,DLG,INST,ID,VAL,ILST,ROOT S ROOT=""
- I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT^ORWDX2
- I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)"  G XROOT^ORWDX2
- I +RSPID=RSPID  S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT^ORWDX2
+ I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT
+ I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)"  G XROOT
+ I +RSPID=RSPID  S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT
  Q:ROOT=""
- G XROOT^ORWDX2
+XROOT S (ILST,I)=0 F  S I=$O(@ROOT@(I)) Q:I'>0  D
+ . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
+ . S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
+ . I '$L(ID) S ID="ID"_DLG
+ . S VAL=$G(@ROOT@(I,1))
+ . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
+ . I $E(RSPID)="C",(ID="START"),VAL Q  ; skip literal start time on copy
+ . S LST($$NXT)="~"_DLG_U_INST_U_ID
+ . I $L(VAL) D
+ .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
+ . I $D(@ROOT@(I,2))>1 D
+ .. S J=0 F  S J=$O(@ROOT@(I,2,J)) Q:J'>0  D
+ ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
+ I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J)
+ Q
 SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ;
  ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog,
@@ -53,5 +77,5 @@
  I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG")
  I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT")
- ;=====================================================
+ ;=======
  ; Changed for v26.27 (RV)
  S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O")
@@ -62,5 +86,5 @@
  ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
  ;E  S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
- ;=====================================================
+ ;=======
  I DLG="PS MEDS" S ORWP94=1 D
  . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY"
@@ -143,4 +167,7 @@
  .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2)
  .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID)
+ .. S PSOSITE=$G(^SC(+ORL,"AFRXSITE")) ;+ORL is hospital location from ORWDX
+ .. Q:PSOSITE=""  ;Quits with no autofinish if File#44 does not point to File#59
+ .. I $P($G(^PS(59,PSOSITE,"RXFIN")),"^",1)="Y",$$GET1^DIQ(100,+ORDERID_",",12)="OUTPATIENT PHARMACY" D EN^PSOAFIN ;vfam
  . S ORWLST(ORWI)=ORDERID,X=""
  . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q
@@ -150,4 +177,10 @@
  I $G(ORLAB) D BTS^ORMBLD(ORVP)
  Q
+EXTVAL(IVAL,DLG) ; External value given a dlg ptr
+ N ORDIALOG
+ S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2)
+ S ORDIALOG(DLG,1)=IVAL
+ I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL  ; free text date/time
+ Q $$EXT^ORCD(DLG,1)  ; all others
 DLGID(VAL,ORIFN) ; return dlg IEN for order
  S VAL=$P(^OR(100,+ORIFN,0),U,5)
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPT.m	(revision 636)
@@ -1,13 +1,37 @@
-ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;3/18/05  10:50
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215**;Dec 17, 1997
- ;
- ; Ref. to ^UTILITY via IA 10061
- ; 
+ORWPT ; SLC/KCM/REV - Patient Lookup Functions ;11/23/06  10:50
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,132,149,206,187,190,215,269**;Dec 17, 1997 LOCAL ;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License
+ ;;VOE VWPT PACKAGE ENHANCEMENT UPDATES ADDED 11/14/06
+ ;
+ Q 
 IDINFO(REC,DFN) ; Return identifying information for a patient
+ ;VWPT BELOW ADD HRN AND ALT HRN
+ ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME^HRN^ALTHRN
  ; PID^DOB^SEX^VET^SC%^WARD^RM-BED^NAME
  N X0,X1,X101,X3,XV  ; name/dob/sex/ssn, ward, room-bed, sc%, vet
  S X0=$G(^DPT(DFN,0)),X1=$G(^(.1)),X101=$G(^(.101)),X3=$G(^(.3)),XV=$G(^("VET"))
- S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249
- Q
+ ;VWPT ENHANCED
+ N HRN,ID
+ S HRN=$$HRN^DGLBPID(DFN)
+ S ID=$$ID^DGLBPID(DFN)
+ I (ID=HRN)&(HRN'="") D
+ .S REC=U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249
+ E  D
+ .S REC=$$ID^DGLBPID(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U)_U_$$HRNRET(DFN)_U_$$ALTHRN^ORWPT2(DFN) ;DG249
+ ;S REC=$$SSN^DPTLK1(DFN)_U_$$DOB^DPTLK1(DFN,2)_U_$P(X0,U,2)_U_$P(XV,U)_U_$P(X3,U,2)_U_$P(X1,U)_U_$P(X101,U)_U_$P(X0,U) ;DG249
+ ;END VWPT
+ Q
+ ;VWPT RETURN HRN .CHECK FOR "sensitive" patients
+HRNRET(DFN) ;
+ N IRET
+ S IRET=$$HRN^DGLBPID(DFN) ;$$HRN^VWVOEDPT(DFN)
+ ;I (IRET'="")&$$SCREEN^DPTLK1(DFN) Q "*SENSITIVE*"  ;"HRN SENSITIVE"
+ I (IRET'="") Q "'"_IRET_"'" ;"HRN:"_"'"_IRET_"'"
+ Q ""
+ ; END VWPT
 PTINQ(REF,DFN) ; Return formatted pt inquiry report
  K ^TMP("ORDATA",$J,1)
@@ -43,25 +67,20 @@
  ;  1    2   3   4    5      6    7    8       9       10      11  12
  ; NAME^SEX^DOB^SSN^LOCIEN^LOCNM^RMBD^CWAD^SENSITIVE^ADMITTED^CONV^SC^
- ; 13  14  15  16
- ; SC%^ICN^AGE^TS
+ ;VWPT HRN , ALTERNATE HRN
+ ; 13  14  15  16  17  18
+ ; SC%^ICN^AGE^TS^HRN^AltHRN
+ ; ;
+ ; ;end vwpt
+ ;
  ;
  ; for CCOW (RV - 2/27/03)  name="-1", location=error message
  I '$D(^DPT(DFN,0)) S REC="-1^^^^^Patient is unknown to CPRS." Q
  ;
- N X
+ N X,ID,HRN
  K ^TMP("ORWPCE",$J) ; delete PCE 'cache' when switching patients
- S X=^DPT(DFN,0),REC=$P(X,U,1,3)_U_$P(X,U,9)_U_U_$G(^(.1))_U_$G(^(.101))
- S X=$P(REC,U,6) I $L(X) S $P(REC,U,5)=+$G(^DIC(42,+$O(^DIC(42,"B",X,0)),44))
- S $P(REC,U,8)=$$CWAD^ORQPT2(DFN)_U_$$EN1^ORQPT2(DFN)
- ; I $P(REC,U,9) D EN2^ORQPT2(DFN)  ;update DG security log ; DG249
- S X=$G(^DPT(DFN,.105)) I X S $P(REC,U,10)=$P($G(^DGPM(X,0)),U)
- S:'$D(IOST) IOST="P-OTHER"
- S $P(REC,U,11)=$$OTF^OR3CONV(DFN,1)
- D ELIG^VADPT S $P(REC,U,12)=$G(VAEL(3)) ;two pieces: SC^SC%
- I $L($T(GETICN^MPIF001)) S X=+$$GETICN^MPIF001(DFN) S:X>0 $P(REC,U,14)=X
+ D VWPT1^ORWPT2 ;moved code to ORWPT2 to save space
  S $P(REC,U,15)=$$AGE(DFN,$P(REC,U,3))
  S $P(REC,U,16)=+$G(^DPT(DFN,.103)) ; treating specialty
- K VAEL,VAERR ;VADPT call to kill?
- S ^DISV(DUZ,"^DPT(")=DFN
+ D VWPT2^ORWPT2
  Q
 SHARE(VAL,IP,HWND,DFN) ; Set global to share DFN with other applications
@@ -83,5 +102,5 @@
  S (I,IEN)=0,XREF=$S($L(ID)=5:"BS5",1:"BS")
  F  S IEN=$O(^DPT(XREF,ID,IEN)) Q:'IEN  D
- . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN)  ; DG249
+ . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN)  ; DG249
  Q
  ;
@@ -98,5 +117,5 @@
  .I ((ORPIEN<0)!(ORPIEN="")) Q
  .S ORCNT=ORCNT+1
- .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
+ .S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;$$SSN^DPTLK1(ORPIEN) ; DG249.
  ;
  Q
@@ -106,5 +125,5 @@
  S (I,IEN)=0
  F  S IEN=$O(^DPT("SSN",ID,IEN)) Q:'IEN  D
- . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$SSN^DPTLK1(IEN)  ; DG249
+ . S I=I+1,LST(I)=IEN_U_$P(^DPT(IEN,0),U)_U_$$DOB^DPTLK1(IEN,2)_U_$$ID^DGLBPID(IEN) ;$$SSN^DPTLK1(IEN)  ; DG249
  Q
  ;
@@ -124,5 +143,5 @@
  ..I (ORPIEN'=ORPT) Q
  ..S ORCNT=ORCNT+1
- ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$SSN^DPTLK1(ORPIEN) ; DG249.
+ ..S LST(ORCNT)=ORPIEN_U_$P(^DPT(ORPIEN,0),U)_U_$$DOB^DPTLK1(ORPIEN,2)_U_$$ID^DGLBPID(ORPIEN) ;SSN^DPTLK1(ORPIEN) ; DG249.
  ;
  Q
@@ -237,2 +256,3 @@
  ;NDBI(X) ; National Database Integration site 1 = yes  0 = no
  ; N R,G S X="A7RDUP" X ^%ZOSF("TEST") S R=$T,G=$S($D(^A7RCP):1,1:0),X=R+G,X=$S(X=2:1,1:0) Q X
+ ;
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRP1.m	(revision 636)
@@ -1,4 +1,4 @@
-ORWRP1 ; ALB/MJK,dcm Report Calls ;9/18/96  15:02
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262**;Dec 17, 1997;Build 3
+ORWRP1 ; ALB/MJK,dcm Report Calls ;7/20/07  14:43
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,160,262,269**;Dec 17, 1997;Build 28
  ;
 AHS(ROOT,ORDFN,ORHS,ALPHA,OMEGA,DTRANGE,REMOTE,ORMAX,ORFHIE) ; - get adhoc health summary report
@@ -94,5 +94,5 @@
 VITALS(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- get vitals report
  D START^ORWRP(132,"VITALSB^ORWRP1(.ROOT,.ORDFN,.ID,.ALPHA,.OMEGA,.ORDTRNG,.REMOTE,.ORMAX,.ORFHIE)")
- Q
+ D EN^GMRVPGC(ORDFN) Q
 VITALSB(ROOT,ORDFN,ID,ALPHA,OMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE) ; -- build vitals report
  N ORVP,XQORNOD,ORSSTRT,ORSSTOP
Index: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRPP1.m
===================================================================
--- FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRPP1.m	(revision 631)
+++ FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWRPP1.m	(revision 636)
@@ -1,8 +1,7 @@
 ORWRPP1 ; slc/dcm - Background Report Prints (cont.) ; 12/05/02  11:02
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,160,192,263**;Dec 17, 1997;Build 9
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,160,192**;Dec 17, 1997
 MEDB(ROOT,ORDFN,OREXAMID,ORALPHA,OROMEGA,ORDTRNG,REMOTE,ORMAX,ORFHIE)  ;Print Medicine report
  K ^TMP("MCAR",$J)
- ;I '$D(^MCAR(690,"AC",ORDFN)) Q
+ I '$D(^MCAR(690,"AC",ORDFN)) Q
  N ORHFS,%,%I,DA,DILCT,DISTP,S1,S2,S4,S6,TY,WH
  S ORHFS=1
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBINGO.m	(revision 636)
@@ -1,9 +1,8 @@
-PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;8/1/07 1:45pm
- ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268,275**;DEC 1997;Build 8
+PSOBINGO ;BHAM ISC/LC - BINGO BOARD OPTION DRIVER ;1/18/06 9:09am
+ ;;7.0;OUTPATIENT PHARMACY;**12,28,56,125,152,232,268**;DEC 1997;Build 9
  ;External Ref. to ^PS(55 is supp. by DBIA# 2228
  ;External Ref. to ^PSDRUG(, is supp. by DBIA# 221
  ;
- ;*232 add ATIC xref set/kill code here
- ;*275 BA xref sometimes gets corrupted, kill bad BA xref and quit
+ ;PSO*7*232 add ATIC xref set/kill code here
  ;
  S (FLAG,FLAG1)=0,(TRIPS,JOES,ADV,DGP)="" G:'$G(PSOAP) END D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
@@ -85,10 +84,5 @@
 FIRST ;Set 1st dup
  S DR="11////A" D ^DIE K DR,CNT
-BROW S DA=SDA,NOPE=0,CNT=0
- F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA))  D  Q:NOPE
- . ;add check for bad xref and kill        *275
- . I '$D(^PS(52.11,NIEN,0)) K ^PS(52.11,"BA",NAM,NIEN) Q
- . D:$D(^PS(52.11,"BI")) BICK Q:CNT>0
- . D SETNEW
+BROW S DA=SDA,NOPE=0,CNT=0 F NIEN=0:0 S NIEN=$O(^PS(52.11,"BA",NAM,NIEN)) Q:'NIEN!(NIEN=$G(DA))  D:$D(^PS(52.11,"BI")) BICK Q:CNT>0  D SETNEW Q:NOPE
  Q
 SETNEW S SSN1=$O(^PS(52.11,"BA",NAM,NIEN,0)),ADFN=$P(^PS(52.11,NIEN,0),"^"),CNT=1 I SSN1=SSN S NOPE=1 Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSU1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOBPSU1 ;BIRM/MFR - BPS (ECME) Utilities 1 ;10/15/04
- ;;7.0;OUTPATIENT PHARMACY;**148,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,260**;DEC 1997;Build 84
  ;Reference to $$EN^BPSNCPDP supported by IA 4415
  ;References to $$NDCFMT^PSSNDCUT,$$GETNDC^PSSNDCUT supported by IA 4707
@@ -45,5 +45,5 @@
  I $$NDCFMT^PSSNDCUT($G(NDC))="" D
  . S NDC=$$GETNDC^PSSNDCUT($$GET1^DIQ(52,RX,6,"I"),$$RXSITE^PSOBPSUT(RX,RFL),+$G(CMOP))
- . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1)
+ . I $G(NDC)'="" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP))
  ;
  ; - Creating ECME Activity Log on the PRESCRIPTION file
@@ -63,5 +63,4 @@
  I $G(RVTX)="",FROM="ED" S RVTX="RX EDITED"
  S RESP=$$EN^BPSNCPDP(RX,RFL,$$DOS(RX,RFL,.DATE),FROM,NDC,$G(RVTX),$G(OVRC),,$G(CLA),$G(PA))
- I $$STATUS^PSOBPSUT(RX,RFL)="E PAYABLE" D SAVNDC^PSONDCUT(RX,RFL,NDC,+$G(CMOP),1)
  ;
  ; - Reseting the Re-transmission flag
@@ -70,10 +69,9 @@
  ; - Logging ECME Activity Log to the PRESCRIPTION file
  I $G(ALTX)="" D
- . N X,ROUTE S (ROUTE,X)=""
- . S ROUTE=$S(FROM="RF":$$GET1^DIQ(52.1,RFL_","_RX_",",2),FROM="OF":$$GET1^DIQ(52,RX_",",11),1:"")
- . S:FROM="OF" X=ROUTE_" FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
- . S:FROM="RF" X=ROUTE_" REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . N X S X=""
+ . S:FROM="OF" X="WINDOW FILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . S:FROM="RF" X="WINDOW REFILL(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="RN" X="RX RENEWED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
- . S:FROM="PL" X="PRINTED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
+ . S:FROM="PL" X="SUSP LABEL PRINTED(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="PE"!(FROM="PP") X="PULLED FROM SUSPENSE(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
  . S:FROM="PC" X="CMOP TRANSMISSION(NDC:"_$$GETNDC^PSONDCUT(RX,RFL)_")"
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBPSUT.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOBPSUT ;BIRM/MFR - BPS (ECME) Utilities ; 07 Jun 2005  8:39 PM
- ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
  ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
  ;Reference to IBSEND^BPSECMP2 supported by IA 4411
@@ -26,11 +26,9 @@
  ;
  ; - Get the REFILL # (multiple IEN)
- N STATUS
  I '$D(RFL) S RFL=$$LSTRFL^PSOBPSU1(RX)
  ; - Not the latest fill for the prescription
  I RFL'=$$LSTRFL^PSOBPSU1(RX) Q 0
- ; - Status not ACTIVE, DISCONTINUED, or EXPIRED
- S STATUS=$$GET1^DIQ(52,RX,100,"I")
- I STATUS'=0&(STATUS'=11)&(STATUS'=12) Q 0
+ ; - Status not ACTIVE
+ I $$GET1^DIQ(52,RX,100,"I")'=0 Q 0
  ; Will suspend for CMOP
  I '$G(IGCMP),$$CMOP(RX,RFL) Q 0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBUILD.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS  [ 07/15/96  5:25 PM ] ;6/21/07 8:20am
- ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235,206**;DEC 1997;Build 39
+PSOBUILD ;IHS/DSD/JCM - BUILD ARRAY OF PATIENTS CURRENT MEDS  [ 07/15/96  5:25 PM ]
+ ;;7.0;OUTPATIENT PHARMACY;**23,82,119,132,235**;DEC 1997
  ;External reference ^PS(50.606 supported by DBIA 2174
  ;External reference ^PS(50.7 supported by DBIA 2223
@@ -45,5 +45,5 @@
  S PSODRG=+$P(PSORX0,"^",6) G:'$D(^PSDRUG(PSODRG,0)) GETX S PSODRUG0=^PSDRUG(PSODRG,0),PSOVACL=$P(PSODRUG0,"^",2),PSODYS=$P(PSORX0,"^",8)
  ;
- I PSOST0<12!(PSOST0=16),PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
+ I PSOST0<12,PSOEXPDT<DT D:$P(PSORX0,"^",15)'=11
  .S PSOST0=11,$P(PSORX0,"^",15)=11 N DIE,DIC,DR,DA,PSOBEXDA S DIE=52,(DA,PSOBEXDA)=PSOBUILD("RX"),DR="100////11" D ^DIE K DIE,DIC,DR
  .D ECAN^PSOUTL(DA) K DA
@@ -61,6 +61,6 @@
  I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" S PSOSTN=PSOSTN_"M"
  S CLOZPT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
- I 'CLOZPT,($P(PSODRUG0,"^",3)["A")&($P(PSODRUG0,"^",3)'["B") S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
- K CLOZPT I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S PSOSTN=PSOSTN_"C"
+ I 'CLOZPT,$P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S PSOSTN=PSOSTN_"B",PSOSTF=PSOSTF_"B"
+ K CLOZPT I $P(PSODRUG0,"^",3)["W" S PSOSTN=PSOSTN_"C"
  I $D(^PS(53,+$P(PSORX0,"^",3),0)),'$P(^(0),"^",5) S PSOSTN=PSOSTN_"D"
  I PSOST0=1 S PSOSTN=PSOSTN_"E"
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN2.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOCAN2 ;BHAM ISC/JMB - modular rx cancel with speed ability drug check ; 10/23/06 11:30am
- ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**8,18,62,46,88,164,235,148,259**;DEC 1997;Build 5
  ;External reference to ^PSDRUG supported by dbia 221
 REINS N DODR
@@ -30,5 +30,5 @@
  . N ACTION
  . D ECMESND^PSOBPSU1(RXIEN,,,$S($O(^PSRX(RXIEN,1,0)):"RF",1:"OF"))
- . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","Q")
+ . I $$FIND^PSOREJUT(RXIEN) S ACTION=$$HDLG^PSOREJU1(RXIEN,,"79,88","OF","IOQ","I")
  ;
  W !?3,"Prescription #",RX," "
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN4.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN4.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCAN4.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOCAN4 ;BIR/SAB-rx speed dc listman ; 10/23/06 11:50am
- ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268**;DEC 1997;Build 9
+PSOCAN4 ;BIR/SAB-rx speed dc listman ; 11/3/06 9:50pm
+ ;;7.0;OUTPATIENT PHARMACY;**20,24,27,63,88,117,131,259,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to File #200 supported by DBIA 224
  ;External reference NA^ORX1 supported by DBIA 2186
@@ -52,12 +68,15 @@
 OK S ORD=SAVORD,ORN=SAVORN Q
 NOOR ;ask nature of order
- D FULL^VALM1
- K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP
- .S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVR"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:""))
- .I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q
- .S DIRUT=1 K PSONOOR
- S DIR("A")="Nature of Order: ",DIR("B")=$S($G(DODR):"SERVICE CORRECTED",1:"WRITTEN")
- S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;R:SERVICE REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
- D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y
+ ;vfah set nature of order automatically for autofinish,rx
+ I $G(PSOAFYN)'="Y" D FULL^VALM1 ;vfah
+ I $G(PSOAFYN)'="Y" K DIR,DTOUT,DTOUT,DIRUT I $T(NA^ORX1)]"" D  Q:$D(DIRUT)  G NOORXP ;vfah
+ .I $G(PSOAFYN)'="Y" S PSONOOR=$$NA^ORX1("S",0,"B","Nature of Order",0,"WPSDIVX"_$S(+$G(^VA(200,DUZ,"PS")):"E",1:"")) ;vfah
+ .I $G(PSOAFYN)'="Y" I +PSONOOR S PSONOOR=$P(PSONOOR,"^",3) Q  ;vfah
+ .I $G(PSOAFYN)'="Y" S DIRUT=1 K PSONOOR ;vfah
+ I $G(PSOAFYN)'="Y" S DIR("A")="Nature of Order: ",DIR("B")=$S($G(DODR):"SERVICE CORRECTED",1:"WRITTEN") ;vfah
+ I $G(PSOAFYN)'="Y" S DIR(0)="SA^W:WRITTEN;V:VERBAL;P:TELEPHONE;S:SERVICE CORRECTED;D:DUPLICATE;I:POLICY;X:REJECTED"_$S(+$G(^VA(200,DUZ,"PS")):";E:PROVIDER ENTERED",1:"")
+ I $G(PSOAFYN)'="Y" D ^DIR K DIR,DTOUT,DTOUT Q:$D(DIRUT)  S PSONOOR=Y ;vfah
+ I $G(PSOAFYN)="Y" S PSONOOR="S" ;vfah sets nature of order to service correction for autofinish,rx
+ ;vfah end of set nature of order
 NOORXP I $G(PSOCANRA),'$G(PSOCANRZ) D REQ
 NOORX S:$D(DIRUT)&($G(SPEED)) VALMBCK="Q"
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCMOP.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ; 6/28/07 7:35am
- ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148,274**;DEC 1997;Build 8
+PSOCMOP ;BIR/HTW-Rx Order Entry Screen for CMOP ;02/19/98  9:21 AM 
+ ;;7.0;OUTPATIENT PHARMACY;**2,16,21,27,43,61,126,148**;DEC 1997
  ;External reference to ^PS(55 supported by DBIA 2228
  ;External reference to ^PSDRUG supported by DBIA 221
@@ -79,5 +79,5 @@
  D REVERSE^PSOBPSU1(RXN,,"DC",3)
  Q
-ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
+ACT I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCPC.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ; 7/13/07 10:21am
- ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201,275**;DEC 1997;Build 8
+PSOCPC ;BHAM ISC/BAB - PHARMACY CO-PAY APPLICATION ;06/09/92
+ ;;7.0;OUTPATIENT PHARMACY;**10,9,71,85,114,157,143,239,201**;DEC 1997
  ;
  ;REF/IA
@@ -79,6 +79,4 @@
  . D ASKEXEM
  I $D(PSOCHG) D
- . ;PSO*7*275 IBQ node should not be present in some cases.
- . K ^PSRX(PSODA,"IBQ")
  . S:PSOSCP<50&($TR(PSOIBQ,"^")'="")&($P($G(^PS(53,+$G(PSOPATST),0)),"^",7)'=1) ^PSRX(PSODA,"IBQ")=PSOIBQ
  . D RESET^PSORN52D  ;set SC/EI on ICD node
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m	(revision 636)
@@ -1,10 +1,9 @@
-PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm
- ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246**;DEC 1997;Build 12
+PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;9/14/05 1:13pm
+ ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212**;DEC 1997
  ;External Ref. to ^PS(55 DBIA# 2228
  ;External Ref. to ^DPT DBIA# 10035
  ;External Ref. to ^PSDRUG DBIA# 221
  ;
- ;*212 don't allow this request, if monthly compile is running
- ;*246 alter SRCH1 For loop to not init to numeric values
+ ;PSO*212 don't allow this request, if monthly compile is running
  ;
  Q:$$MTHLCK(1)            ;get lock, quit if already locked    PSO*212
@@ -33,13 +32,8 @@
  Q
  ;
-SRCH1 D INI
- ;refill
- S PSDT1=PSDT                                ;*246
- F  S PSDT1=$O(^PSRX("AL",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
+SRCH1 D INI F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AL",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
  .S CDT=$P(PSDT1,".") F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT1,RXN)) Q:'RXN  S RXF="" F  S RXF=$O(^PSRX("AL",PSDT1,RXN,RXF)) Q:RXF=""  D CHK
  .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
- ;partial fill
- S PSDT1=PSDT                                ;*246
- F  S PSDT1=$O(^PSRX("AM",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
+ F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AM",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
  .S CDT=$P(PSDT1,"."),RXN=0 F  S RXN=$O(^PSRX("AM",PSDT1,RXN)) Q:'RXN  S RXF=0 F  S RXF=$O(^PSRX("AM",PSDT1,RXN,RXF)) Q:RXF=""  S PAR=1 D CHK
  .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODEA.m	(revision 636)
@@ -1,4 +1,4 @@
-PSODEA ;BHAM ISC/  - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 10/17/07 7:41am
- ;;7.0;OUTPATIENT PHARMACY;**206**;DEC 1997;Build 39
+PSODEA ;BHAM ISC/  - HELP TEXT FOR DEA FIELD IN DRUG FILE ; 06/03/92 17:28
+ ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
  W !,"THE SPECIAL HANDLING CODE IS A 2 TO 6 POSTION FIELD.  IF APPLICABLE,",!,"A SCHEDULE CODE MUST APPEAR IN THE FIRST POSITION.  FOR EXAMPLE,"
  W !,"A SCHEDULE 3 NARCOTIC WILL BE CODED '3A' AND A SCHEDULE 2 DEPRESSANT",!,"WILL BE CODED '2L'.  THE CODES ARE:",!
@@ -21,8 +21,8 @@
  ;;R          RESTRICTED ITEMS
  ;;S          SUPPLY ITEMS
- ;;B          ALLOW REFILL (SCH. 3, 4, 5 ONLY)
+ ;;B          ALLOW REFILL (SCH. 3, 4, 5 NARCOTICS ONLY)
  ;;W          NOT RENEWABLE
  ;;
 EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE
- I X["B",(+X<3) W !,"The B designation is only valid for schedule 3, 4, 5 !",$C(7) K X Q
+ I X["B",(+X<3!(X'["A")) W !,"The B designation is only valid for schedule 3, 4, 5 narcotics !",$C(7) K X Q
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODGDGI.m	(revision 636)
@@ -1,4 +1,4 @@
-PSODGDGI ;BIR/SAB - drug drug interaction checker ; 6/28/07 7:36am
- ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243,274**;DEC 1997;Build 8
+PSODGDGI ;BIR/SAB - drug drug interaction checker ;4/14/93
+ ;;7.0;OUTPATIENT PHARMACY;**10,27,48,130,144,132,188,207,243**;DEC 1997;Build 22
  ;External reference to ^PS(56 supported by DBIA 2229
  ;External reference to ^PSDRUG supported by DBIA 221
@@ -41,5 +41,5 @@
  I +CRIT S PSODI=1,DIC="^PS(52.4,",DLAYGO=52.4,DIC(0)="L",(DINUM,X)=PSOX("IRXN"),DIC("DR")="1////"_PSODFN_";2////"_DUZ_";4///"_DT_";7///"_1_";7.1///"_SER_";7.2///"_DGI K DD,DO D FILE^DICN K DD,DO
  S:$G(DGS)'="" $P(^PSRX(PSOX("IRXN"),"DRI"),"^")=SERS,$P(^PSRX(PSOX("IRXN"),"DRI"),"^",2)=DGS  K PSODI,CRIT,DIC,DLAYGO,DINUM,DGI,DGS,SER,SERS Q
-BLD I $D(^XUSEC("PSORPH",DUZ)) D PHARM Q
+BLD I $D(^XUSEC("PSORPH",DUZ)) S PSORX("PHARM")=DUZ D PHARM Q
  S LSI=$P(^PSRX(+PSOSD(STA,DRG),0),"^")_"/"_$P(^PSDRUG($P(^(0),"^",6),0),"^")_","_LSI,DGI=$P(PSOSD(STA,DRG),"^")_","_DGI,SER=IT_","_SER I $P(PSOSD(STA,DRG),"^",9),$P(^PS(56,IT,0),"^",4)=1 S $P(^PSRX(+PSOSD(STA,DRG),"STA"),"^")=4
  I $P(^PS(56,IT,0),"^",4)=2 S SERS=IT_","_SERS,DGS=$P(PSOSD(STA,DRG),"^")_","_DGS
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR.m	(revision 636)
@@ -1,4 +1,4 @@
-PSODIR ;BHAM ISC/SAB - asks data for rx order entry ; 9/17/07 5:03pm
- ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264,275**;DEC 1997;Build 8
+PSODIR ;BHAM ISC/SAB - asks data for rx order entry ;02/12/93 8:49
+ ;;7.0;OUTPATIENT PHARMACY;**37,46,111,117,146,164,211,264**;DEC 1997;Build 19
  ;External reference PSDRUG( supported by DBIA 221
  ;External reference PS(50.7 supported by DBIA 2223
@@ -66,6 +66,5 @@
  N DA K INS1,DD,DIR,DIRUT S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S DD=$G(DD)+1
  I $G(DD)=1 S PSODIR("INS")=$G(PSODIR("SIG",1)) G INSD
- ;PSO*7*275 remove check for PSOINSFL just check for multi line sig
- I $G(DD)>1 D  G EX
+ I ($G(PSOINSFL)=1&($G(DD)>1))!($G(PSOFDR)&($G(ORD))&($P($G(^PS(52.41,+$G(ORD),"EXT")),"^")'="")&($G(DD)>1)) D  G EX
  .K ^TMP($J) S D=0 F  S D=$O(PSODIR("SIG",D)) Q:'D  S ^TMP($J,"SIG",D,0)=PSODIR("SIG",D)
  .S DWPK=2,DWLW=80,DIC="^TMP($J,""SIG""," D EN^DIWE K PSODIR("SIG")
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;6/21/07 8:22am
- ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268,206**;DEC 1997;Build 39
+PSODIR1 ;IHS/DSD - ASKS DATA FOR RX ORDER ENTRY CONT. ;02/17/93 17:03
+ ;;7.0;OUTPATIENT PHARMACY;**23,46,78,102,121,131,146,166,184,222,268**;DEC 1997;Build 9
  ;Ext ref ^PS(55-DBIA 2228, ^PSDRUG(-DBIA 221
 PTSTAT(PSODIR) ;
@@ -109,6 +109,6 @@
  .S PSOX=11,PSOX1=$S($P($G(PSODIR("PTST NODE")),"^",4)>PSOX:PSOX,1:$P($G(PSODIR("PTST NODE")),"^",4)),PSOX=$S(PSOX1=11:PSOX,1:PSOX1)
  .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
- I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) D  G REFILLX
- .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2)!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
+ I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") D  G REFILLX
+ .I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!'$O(^PSRX(+$G(PSODIR("IRXN")),1,0))!('$G(PSOLOKED)) D  Q
  ..S VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics.") W !,VALMSG,!
  ..S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODIR3.m	(revision 636)
@@ -1,4 +1,4 @@
-PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;4/25/07 8:28am
- ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222,206**;DEC 1997;Build 39
+PSODIR3 ;ISC-BIRM/SAB - rx order entry contd ;09/27/96
+ ;;7.0;OUTPATIENT PHARMACY;**3,46,184,222**;DEC 1997;Build 12
  ;
 EXP(PSODIR) ;
@@ -77,6 +77,6 @@
  .S (PSOX,PSOMAX)=$S($G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSODIR("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSODIR("DAYS SUPPLY")=7):1,$D(CLOZPAT):0,1:11)
  .S PSDY=PSODIR("DAYS SUPPLY"),PSDY1=$S(PSDY<60:11,PSDY'<60&(PSDY'>89):5,PSDY=90:3,1:0) S PSOX=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
- K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q
- .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["A":"this narcotic drug.",1:"this drug.")
+ K PSOELSE I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
+ .S VALMSG="No refills allowed on "_$S($G(PSODRUG("DEA"))["F":"this drug.",1:"Narcotics ..")
  .W !,VALMSG,!
  .S:$D(PSODIR("FIELD")) PSODIR("FIELD")=0 S PSODIR("# OF REFILLS")=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISP.m	(revision 636)
@@ -1,4 +1,20 @@
 PSODISP ;BIR/SAB,PWC-MANUAL BARCODE RELEASE FUNCTION ;03/02/93
- ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200**;DEC 1997;Build 7
+ ;;7.0;OUTPATIENT PHARMACY;**15,71,131,156,185,148,247,200,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference to $$SERV^IBARX1 supported by DBIA 2245
  ;Reference to ^PSD(58.8 supported by DBIA 1036
@@ -14,6 +30,8 @@
  S Y=$G(^PS(59,PSOSITE,"IB")),PSOIBSS=$$SERV^IBARX1(+Y) I 'PSOIBSS D IBSSR^PSOUTL I 'PSOIBFL D   G EXIT
  .W $C(7),!!,"The IB SERVICE/SECTION defined in your site parameter file is not valid.",!,"You will not be able to release any medication until this is corrected!",!
-AC1 W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2)
- S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y
+AC1 I $G(PSOAFYN)'="Y" W !! S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
+ I $G(PSOAFYN)="Y" S PSIN=+$P($G(^PS(59.7,1,49.99)),"^",2) ;vfah - VOE
+ I $G(PSOAFYN)'="Y" S DIC("S")="I $D(^XUSEC(""PSORPH"",+Y))",DIC("A")="Enter PHARMACIST: ",DIC="^VA(200,",DIC(0)="QEAM" D ^DIC G:"^"[X EXIT K DIC G:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))!(Y=-1) EXIT S PSRH=+Y ;vfah - VOE
+ I $G(PSOAFYN)="Y" S PSRH=DUZ,PSZAR="0" ;vfah - VOE
  ;check for Drug Acct background job K8 & K7.1
  S X="PSA IV ALL LOCATIONS",DIC(0)="MZ",DIC=19.2 D ^DIC I Y=-1 K DIC,X,Y G BC
@@ -25,6 +43,8 @@
  K PSA,DIC,DA,X,Y,DIQ
 BC ;
+ I $G(PSOAFYN)="Y",$G(PSZAR)="1" Q  ;vfah - VOE
  K MAN I $G(RXP),$D(DISGROUP),$D(BINGNAM),($D(BINGDIV)!$D(BNGPDV)!$D(BNGRDV)),($D(BINGRO)!$D(BINGRPR)) D REL^PSOBING1 K BINGNAM,BINGDIV,BINGRO,BINGRPR,BNGPDV,BNGRDV
- Q:$G(POERR)  W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR
+ I $G(PSOAFYN)'="Y" Q:$G(POERR)  W !! K CMOP,ISUF,DIR,LBL,LBLP S DIR("A")="Enter/Wand PRESCRIPTION number",DIR("?")="^D HELP^PSODISP",DIR(0)="FO" D ^DIR ;vfah - VOE
+ I $G(PSOAFYN)="Y" S X=RXN,PSZAR="1" ;vfah - VOE
  I $D(DIRUT)!($D(DTOUT))!($D(DUOUT)) K DIRUT,DTOUT,DUOUT G AC1
  I X'["-" D BCI W:'$G(RXP) !,"INVALID PRESCRIPTION NUMBER" G:'$G(RXP) BC S MAN=1 G BC1
@@ -62,5 +82,5 @@
  .I $$MANREL^PSOBPSUT(RXP,0,$G(PSOPID))="^" K LBLP Q
  .;
- .S:$D(^PSDRUG(QDRUG,660.1)) ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY
+ .S:$D(^PSDRUG(QDRUG,660.1))&($G(PSOAFYN)'="Y") ^PSDRUG(QDRUG,660.1)=^PSDRUG(QDRUG,660.1)-QTY ;vfah - VOE
  .D NOW^%DTC S DIE="^PSRX(",DA=RXP,DR="31///"_%_";23////"_PSRH_";32.1///@;32.2///@",PSODT=% D ^DIE K DIE,DR,DA,LBL
  .;
@@ -78,5 +98,5 @@
  N BFILL S BFILL=0
  S PSOCPRX=$P(^PSRX(RXP,0),"^") D CP^PSOCP
- W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released"
+ I $G(PSOAFYN)'="Y" W !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_" Released" ;vfah - VOE
  ;initialize bingo board variables
  I $G(LBLP),$P(^PSRX(RXP,0),"^",11)["W" S BINGRO="W",BINGNAM=$P(^PSRX(RXP,0),"^",2),BINGDIV=$P(^PSRX(RXP,2),"^",9)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISPS.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISPS.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODISPS.m	(revision 636)
@@ -1,4 +1,20 @@
 PSODISPS ;BIR/SAB-CONTINUATION OF RELEASE FUNCTION ;3/2/93
- ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200**;DEC 1997;Build 7
+ ;;7.0;OUTPATIENT PHARMACY;**15,13,9,27,67,71,156,118,148,247,200,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference ^PS(59.7 supported by DBIA 694
  ;External reference to ^PSDRUG("AQ" supported by DBIA 3165
@@ -39,5 +55,5 @@
  .I $G(IFN),$P($G(^PSRX(RXP,XTYPE,IFN,0)),"^",2)["W" S BINGRPR="W",BNGPDV=$P(^PSRX(RXP,XTYPE,IFN,0),"^",9),BINGNAM=$P($G(^PSRX(RXP,0)),"^",2)
  W:$G(IFN) !?7,"Prescription Number "_$P(^PSRX(RXP,0),"^")_$S('$G(XTYPE):" Partial Fill",1:" Refill(s)")_" Released" I $G(SPEED) G XMIT
- W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released"
+ I $G(PSOAFYN)'="Y" W:'$G(IFN) !?7,"No "_$S($G(XTYPE):"Refill(s)",1:"Partial(s)")_" to be Released" ;vfah - VOE
 XMIT I $G(PSODISP)=2.4 D  ;build an send HL7 v2.4 messages to dispense system
  . F I=0:0 S SUB=$O(^PSRX(RXP,"A",I)) Q:'I  I $P(^PSRX(RXP,"A",I,0),"^",2)="N" D
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRDUP.m	(revision 636)
@@ -1,6 +1,23 @@
 PSODRDUP ;BIR/SAB - Dup drug class checker ;11/1/04 3:38pm
- ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243**;DEC 1997;Build 22
+ ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,39,56,130,132,192,207,222,243,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+ I $G(PSOAFYN)="Y" Q  ;vfam No Dup Drug Check by AutoFinish,Rx - VOE
  S $P(PSONULN,"-",79)="-",(STA,DNM)="" K CLS
  F  S STA=$O(PSOSD(STA)) Q:STA=""  F  S DNM=$O(PSOSD(STA,DNM)) Q:DNM=""!$G(PSORX("DFLG"))  I $P(PSOSD(STA,DNM),"^")'=$G(PSORENW("OIRXN")) D  Q:$G(PSORX("DFLG"))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSODRG.m	(revision 636)
@@ -1,4 +1,20 @@
 PSODRG ;IHS/DSD/JCM-ORDER ENTRY DRUG SELECTION ;03/30/93
- ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268**;DEC 1997;Build 9
+ ;;7.0;OUTPATIENT PHARMACY;**20,23,36,53,54,46,112,139,207,148,243,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference ^PSDRUG supported by DBIA 221
  ;Reference ^PS(50.7 supported by DBIA 2223
@@ -87,4 +103,5 @@
  K NFI Q
 POST ;order checks
+ I $G(PSOAFYN)="Y" G POSTX ;vfam - VOE
  K PSORX("INTERVENE") N STAT,SIG,PTR,NDF,VAP S PSORX("DFLG")=0
  D ^PSOBUILD
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 10/17/07 7:41am
- ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268,206**;DEC 1997;Build 39
+PSOHELP ;BHAM ISC/SAB-outpatient utility routine ; 2/17/93 18:00:36
+ ;;7.0;OUTPATIENT PHARMACY;**3,23,29,48,46,117,131,222,268**;DEC 1997;Build 9
  ;External reference ^PS(51 supported by DBIA 2224
  ;External reference ^PSDRUG( supported by DBIA 221
@@ -63,5 +63,5 @@
  S PSODEA=$P(^PSDRUG(P(5),0),"^",3),CS=0
  I $D(CLOZPAT) S MAX=$S(CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=14):1,CLOZPAT=2&($P(^PSRX(DA,0),"^",8)=7):3,CLOZPAT=1&($P(^PSRX(DA,0),"^",8)=7):1,1:0),MIN=0 Q
- I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) D EN^DDIOL("No refills allowed on "_$S(PSODEA["A":"this narcotic drug.",1:"this drug."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q
+ I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") D EN^DDIOL("No refills allowed on "_$S(PSODEA["F":"this drug.",1:"Narcotics .."),"","!") D EN^DDIOL(" ","","!") S $P(^PSRX(DA,0),"^",9)=0 K X,Y,PSODEA,CS,PTST Q
  F DEA=1:1 Q:$E(PSODEA,DEA)=""  I $E(+PSODEA,DEA)>1,$E(+PSODEA,DEA)<6 S CS=1
  S PSOELSE=CS I PSOELSE D
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHELP3.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOHELP3 ;BHAM ISC/SAB - outpatient utility routine #4 ;2/17/93 18:00:36
- ;;7.0;OUTPATIENT PHARMACY;**20,291**;DEC 1997;Build 2
+ ;;7.0;OUTPATIENT PHARMACY;**20**;DEC 1997
 XREF ;code to create 'APD' xref on Drug Interaction file (#56)
  ;I '$D(ZTSK),'$D(PSMSG) D WAIT^DICD W "Building 'APD' X-Ref."
@@ -16,36 +16,25 @@
  Q
 DRUG ;selects drug and updates Rx file with cost (pso*7*20)
- W !!,"This option will update the drug cost on all fills in the PRESCRIPTION"
- W !,"file (#52) based on the selected date range and the current cost in the"
- W !,"DRUG file (#50).",!
  K X,Y,DA,DIC S DIC(0)="AQEM",DIC=50 D ^DIC I $G(DUOUT) K DIC,Y,X,DA Q
  I Y<0 G OUT
  S (DRG,DA)=+Y K DIC,DR,DIQ S DIC=50,DR=16,DIQ="PSODRG",DIQ(0)="I"
  D EN^DIQ1 S COST=PSODRG(50,DA,16,"I") K PSODRG,DIC,DA,DR,DIQ,DIR
- W ! S DIR("A")="Do you want to exclude Refills and Partials",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q
- S REF=$S(Y:0,1:1)
- S X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
+ W ! S DIR("A")="Do you want to update cost on Refills and Partials too",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I $G(DIRUT) K COST,X,DRG,Y Q
+ S REF=$S(Y:Y,1:0),X1=DT,X2=-485 D C^%DTC S (DEF,Y)=X X ^DD("DD")
  W !!,"You can only go back One Year plus 120 days."
- S %DT(0)=DEF,%DT="AQEX",%DT("A")="Enter starting fill date: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q
- S (FBCK,%DT(0))=Y,%DT("A")="Enter ending fill date: " D ^%DT
+ S %DT(0)=DEF,%DT="AQEX",%DT("A")="How far BACK do you want to go: ",%DT("B")=Y D ^%DT K %DT("B"),DEF I Y<0!($D(DTOUT)) K REF,COST,DRG,X,Y Q
+ S (FBCK,%DT(0))=Y,%DT("A")="How far AHEAD do you want to go: " D ^%DT
  K %DT I Y<0!($D(DTOUT)) K FBCK,REF,COST,DRG,X,Y Q
- S FAHD=Y
- S PSOFUTR=0 I FAHD>(DT-1) S PSOFUTR=1 D
- .W !!,"Since you selected an end fill date of today or in the future, this option"
- .W !,"will update the cost for all existing and suspended fills that have a"
- .W !,"fill date in the future.",!
- K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT
+ S FAHD=Y K DIR,X,Y S DIR(0)="Y",DIR("A")="Do you want to Queue to run at a specific Time",DIR("B")="Yes" D ^DIR K DIR I $D(DIRUT) G OUT
  I Y S PSOQ=1 K ZTDTH D  G OUT
  .S ZTRTN="EN^PSOHELP3",ZTIO="",ZTDESC="Outpatient Pharmacy Rx Cost Update"
- .F G="REF","COST","DRG","FBCK","FAHD","PSOQ","PSOFUTR" S:$D(@G) ZTSAVE(G)=""
- .D ^%ZTLOAD I $D(ZTSK) W !!,"Rxs Cost Update Queued",! K ZTSK
-EN W:'$G(PSOQ) !,"Updating cost. Please wait... "
- S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR) I FDT>FAHD Q
- .S RXN=0 F  S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN  D  W:'$G(PSOQ) "."
- ..I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
- I 'REF G OUT
- D REFILL,PARTIAL
-OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT,PSOFUTR I $D(ZTQUEUED) S ZTREQ="@"
+ .F G="REF","COST","DRG","FBCK","FAHD","PSOQ" S:$D(@G) ZTSAVE(G)=""
+ .D ^%ZTLOAD I $D(ZTSK) W !,"Rxs Cost Update Queued" K ZTSK
+EN W:'$G(PSOQ) ! S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADL",FDT)) Q:'FDT!(FDT>FAHD)  F RXN=0:0 S RXN=$O(^PSRX("ADL",FDT,DRG,RXN)) Q:'RXN  D  W:'$G(PSOQ) "."
+ .I $P($G(^PSRX(RXN,0)),"^",6)=DRG,$P($G(^(2)),"^",2)=FDT S $P(^PSRX(RXN,0),"^",17)=COST
+ .Q:'REF
+ .F I=0:0 S I=$O(^PSRX(RXN,1,I)) Q:'I  S $P(^PSRX(RXN,1,I,0),"^",11)=COST
+ .F I=0:0 S I=$O(^PSRX(RXN,"P",I)) Q:'I  S $P(^PSRX(RXN,"P",I,0),"^",11)=COST
+OUT K G,COST,I,X,Y,REF,RXN,FDT,FAHD,FBCK,DRG,PSOQ,DIRUT I $D(ZTQUEUED) S ZTREQ="@"
  Q
 POST ;post install entry point.  builds new "ADL" xref for file 52 pso*7*20
@@ -58,18 +47,2 @@
  K X,Y,DEF,FTY,IFN S ZTREQ="@"
  Q
-REFILL ;
- N FILL,FDT,RXN
- S FDT=FBCK-1 F  S FDT=$O(^PSRX("AD",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR),FDT>FAHD Q
- .S RXN="" F  S RXN=$O(^PSRX("AD",FDT,RXN)) Q:'RXN  D
- ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
- ..S FILL=0 F  S FILL=$O(^PSRX("AD",FDT,RXN,FILL)) Q:'FILL  I $D(^PSRX(RXN,1,FILL,0)) S $P(^(0),"^",11)=COST
- Q
-PARTIAL ;
-  N FILL,FDT,RXN
-  S FDT=FBCK-1 F  S FDT=$O(^PSRX("ADP",FDT)) Q:'FDT  D  Q:FDT>FAHD
- .I '$G(PSOFUTR),FDT>FAHD Q
- .S RXN="" F  S RXN=$O(^PSRX("ADP",FDT,RXN)) Q:'RXN  D
- ..I $P($G(^PSRX(RXN,0)),"^",6)'=DRG Q
- ..S FILL=0 F  S FILL=$O(^PSRX("ADP",FDT,RXN,FILL)) Q:'FILL  I $D(^PSRX(RXN,"P",FILL,0)) S $P(^(0),"^",11)=COST
- Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLD.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOHLD ;BIR/SAB - hold unhold functionality ;07/15/96
- ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**1,16,21,24,27,32,55,82,114,130,166,148,268**;DEC 1997;Build 9
  ;External reference to ^DD(52-DBIA 999,  VA(200-DBIA 224, NA^ORX1-DBIA 2186,
  ; L, UL, PSOL, and PSOUL^PSSLOCK-DBIA 2789, ^%DTC-DBIA 10000, ^DIE-DBIA 10018, ^DIR-DBIA 10026,
@@ -50,5 +50,5 @@
  . D ECMESND^PSOBPSU1(RX,RFL,,$S(RFL:"RF",1:"OF"))
  . I $$FIND^PSOREJUT(RX,RFL) D
- . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I")
  ;
  I $G(PSORX("PSOL",1))']"" S PSORX("PSOL",1)=DA_"," D ULP G EX
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLEXP.m	(revision 636)
@@ -1,21 +1,11 @@
-PSOHLEXP ;BIR/RTR-Auto expire prescriptions ; 10/10/07 11:16am
- ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148,257**;DEC 1997;Build 19
+PSOHLEXP ;BIR/RTR-Auto expire prescriptions ;10/10/96
+ ;;7.0;OUTPATIENT PHARMACY;**10,22,36,73,148**;DEC 1997
+ ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
  ;
- ;External reference to ^PS(59.7 supported by DBIA 694
- ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
- ;External references to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
-EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,ZZEDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN,CPRSDC
+EN N PSOEXRX,PSOEXCOM,PSOEXSTS,SUSD,PSOEXSTA,ZZDT,IFN,NODE,RF,PIFN,PSUSD,PRFDT,PDA,PSDTEST,ORN
  I '$G(DT) S DT=$$DT^XLFDT
- S X1=DT,X2=-1 D C^%DTC S ZZEDT=X
- S ZZDT=$P($G(^PS(59.7,1,49.99)),"^",8) I +ZZDT=0 S X1=DT,X2=-2 D C^%DTC S ZZDT=X
- F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:ZZDT>ZZEDT  Q:ZZDT=""  D EN1
- Q
-EN1 F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
- .N CPRSDC,CPRSSTA
- .S CPRSDC=",1,7,12,13,"
- .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
- .I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN) I CPRSSTA=0 S ORN=""
+ S X1=DT,X2=-1 D C^%DTC S ZZDT=X
+ F PSOEXRX=0:0 S PSOEXRX=$O(^PSRX("AG",ZZDT,PSOEXRX)) Q:'PSOEXRX  D:$D(^PSRX(PSOEXRX,0))
  .Q:$P($G(^PSRX(PSOEXRX,2)),"^",6)'=ZZDT
- .K CMOP S DA=PSOEXRX I DA D ^PSOCMOPA  ;*257 ;SET UP CMOP() ARRAY
  .S DA=$O(^PS(52.5,"B",PSOEXRX,0))
  .I DA S SUSD=$P($G(^PS(52.5,DA,0)),"^",2) I SUSD,$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
@@ -23,35 +13,22 @@
  .I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
  .S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
- .I PSOEXSTA=13 D  Q
- ..I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
- .I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) I ORN,CPRSDC'[(","_CPRSSTA_",") D
- ..D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
- ..I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
- .I PSOEXSTA=11 I ORN,CPRSDC'[(","_CPRSSTA_",") D
+ .Q:PSOEXSTA=13!(PSOEXSTA="")
+ .I '$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D EN^PSOHLSN1(PSOEXRX,"ZC","") I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
+ ..I PSOEXSTA=12!(PSOEXSTA=14)!(PSOEXSTA=15) D EN^PSOHLSN1(PSOEXRX,"OD","","","A")
+ .I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN,+$$STATUS^ORQOR2(ORN)=6 D
  ..S $P(^PSRX(PSOEXRX,0),"^",19)=1
  ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
- .I PSOEXSTA>9&(PSOEXSTA'=16) Q
+ .Q:PSOEXSTA>9
  .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
- .D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
+ .I '$G(PSUSD) D REVERSE^PSOBPSU1(PSOEXRX,0,"DE",5,"RX EXPIRED")
  .S (PIFN,PSUSD,PRFDT)=0 F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
- .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
  .I $G(PSUSD) I '$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) S PSDTEST=0 D  I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
  ..D REVERSE^PSOBPSU1(PSOEXRX,PSUSD,"DE",5,"RX EXPIRED")
  ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  I $P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD S PSDTEST=1
- ..I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
- ..N PSOORL
- ..S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
- ..N PDA0
- ..;S PDAQ=0
- ..F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
- ...S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0))
- ...I $P(PDA0,"^",3)=PSUSD S PSDTEST=1   ;*257
- ..;Q:'PDAQ
- ..;S PSDTEST=1
- .I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
- .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
+ ..S DA=PSOEXRX K CMOP D ^PSOCMOPA I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))'="L" Q
+ ..S PSDTEST=1
+ .Q:'$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
  .S $P(^PSRX(PSOEXRX,0),"^",19)=1
  .S PSOEXCOM="Prescription past expiration date" D EN^PSOHLSN1(PSOEXRX,"SC","ZE",PSOEXCOM)
- S DIE=59.7,DA=1,DR="49.95///"_ZZDT D ^DIE K DIE,DA,DR
  Q
 NSET ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOHLSN ;BIR/RTR-Send order information to OERR from file 52.41 ;10/10/94
- ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121,292**;DEC 1997;Build 1
+ ;;7.0;OUTPATIENT PHARMACY;**1,7,15,24,27,30,55,46,98,88,121**;DEC 1997
  ;Externel reference EN^ORERR supported by DBIA 2187
  ;
@@ -12,5 +12,4 @@
  I '$G(PSIEN) Q
  I $G(STAT)="OC"!($G(STAT)="OD")!($G(STAT)="CR")!($G(STAT)="DR") D
- .D CHKOLDRX
  .I $D(^PS(52.41,PSIEN,0)) K ^PS(52.41,"AD",$P(^PS(52.41,PSIEN,0),"^",12),+$P($G(^("INI")),"^"),PSIEN),^PS(52.41,"ACL",+$P(^PS(52.41,PSIEN,0),"^",13),+$P(^(0),"^",12),PSIEN),^PS(52.41,"AQ",+$P($G(^PS(52.41,PSIEN,0)),"^",21),PSIEN)
  S PSZERO=$G(^PS(52.41,PSIEN,0)),PSOHSTAT=$G(STAT)
@@ -161,7 +160,2 @@
  .S PVAR=$S(PVAR="":PVAR1,1:PVAR_PVAR1)
  Q
-CHKOLDRX ; when dc a pending renewal - if prior Rx is expired, set piece 19 to 1 so will update CPRS from 'renewed' to 'expired' in PSOHLSN1
- N PSOOLD
- S PSOOLD=$P($G(^PS(52.41,PSIEN,0)),"^",21)
- I PSOOLD'="",$P($G(^PSRX(PSOOLD,"STA")),"^")=11 S $P(^PSRX(PSOOLD,0),"^",19)=1
- Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOHLSN1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOHLSN1 ;BIR/RTR - Send order info to OERR from file 52 ;10/10/94
- ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239,292**;DEC 1997;Build 1
+ ;;7.0;OUTPATIENT PHARMACY;**1,10,24,27,55,46,71,101,99,121,139,157,181,143,235,239**;DEC 1997
  ;Ref #50.606-DBIA 2174
  ;#50.607-2221
@@ -21,5 +21,4 @@
  S COUNT=0,NULLFLDS="F JJ=0:1:LIMIT S FIELD(JJ)="""""
  I '$D(^PSRX(PSRXIEN,0)) Q
- I ($G(STAT)="SC"&($G(PSSTAT)="ZE"))!($G(STAT)="OC")!($G(STAT)="OD") I $D(^PS(52.41,"AQ",PSRXIEN)) D EN^PSOHDR("PRES",PSRXIEN) Q
  I STAT'="SN",STAT'="ZC",'$P($G(^PSRX(PSRXIEN,"OR1")),"^",2) Q
  I $G(STAT)="SC",$G(PSSTAT)="ZE" S $P(^PSRX(PSRXIEN,0),"^",19)=2
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL.m	(revision 636)
@@ -1,7 +1,7 @@
-PSOLBL ;BIR/SAB/RTR-BOTTLE LABEL ;5/9/07 8:57am
- ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244,206**;DEC 1997;Build 39
+PSOLBL ;BIR/SAB/RTR-BOTTLE LABEL ;6/29/06 11:39am
+ ;;7.0;OUTPATIENT PHARMACY;**8,19,30,36,47,71,92,120,157,244**;DEC 1997
  ;DBIAs PSDRUG-221, PS(55-2228, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097
  ;
- ;*244 rem test for part fill when testing status > 11
+ ;*244 remove test for partial fill when testing status > 11
  ;
 DQ I $D(PSOIOS),PSOIOS]"" D DEVBAR^PSOBMST
@@ -68,5 +68,5 @@
  .K PSMP(PSI)
  S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2),PS55=$P($G(X),"^",3),PS55X=$P($G(X),"^",5)
- I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=0
+ I (($G(PS55X)]"")&(PS55>1)&(PS55X<DT)) S PS55=1
  S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
  S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
@@ -74,5 +74,5 @@
  ;S X=$S($D(^PS(55,DFN,0)):^(0),1:""),PSCAP=$P(X,"^",2) S:MW="M" MW=$S(+$P(X,"^",3):"R",1:MW) S MW=$S(MW="M":"REGULAR",MW="R":"CERTIFIED",1:"WINDOW")
  S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
- S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2) PRTFL=0
+ S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W") PRTFL=0
  S VRPH=$P(^PSRX(RX,2),"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$S($D(^SC(PSCLN,0)):$P(^(0),"^",2),1:"UNKNOWN")
  S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBL4.m	(revision 636)
@@ -1,8 +1,7 @@
-PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;12/19/06 10:45am
- ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233,246**;DEC 1997;Build 12
+PSOLBL4 ;BIR/RTR-Set up routine for HL7 interface ;10/20/96
+ ;;7.0;OUTPATIENT PHARMACY;**26,70,156,244,233**;DEC 1997;Build 8
  ;External reference to ^PSDRUG supported by DBIA 221
  ;
  ;*244 - ignore RX's with a status > 11
- ;*246 - send marked drugs & print label (option 4) now working
  ;
  N DIC,AP,X,Y,DPRT,QPRT
@@ -13,12 +12,12 @@
  .F AP=0:0 S AP=$O(^PS(59,PSOSITE,"P",AP)) Q:'AP  I +$P(^PS(59,PSOSITE,"P",AP,0),"^")=DPRT S QPRT=1
  .I '$G(QPRT) S $P(PSOPAR,"^",30)=0
- Q:'$P($G(PSOPAR),"^",30)                ;HL7 interface turned off
+ Q:'$P($G(PSOPAR),"^",30)
  Q:$G(PSOEXREP)
-HL N PSODTM,HHHH,PSOQUE,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,II,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1,NOTMD
+HL N PSODTM,HHHH,HLCOT,HLFLAG,HLFOUR,HLINGF,HLINRX,HLINRX0,HLLOOP,HLNEXT,HLRR,HLRX,HLRXY,LL,PPLHL,PSHALP,HDFN,HLDFN,HNEWDFN,HLDAI,HLOSITE,HLJUST,HLRXYZ,PSOLLN,PSOLLL,PSFLG,HDFN1
  S HLOSITE=$P($G(PSOPAR),"^",30)
  K ^UTILITY($J,"PSOHL"),^UTILITY($J,"PSOHLL"),HLRXY
- S PPLHL=PPL
- S HLFLAG=0 F II=1:1 S HLRX=$P(PPLHL,",",II) D  Q:$G(HLFLAG)
- .S HLNEXT=$P(PPLHL,",",(II+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
+ S PPLHL=PPL G:HLOSITE=4 SOMD
+ S HLFLAG=0 F HLLOOP=1:1 S HLRX=$P(PPLHL,",",HLLOOP) D  Q:$G(HLFLAG)
+ .S HLNEXT=$P(PPLHL,",",(HLLOOP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLAG=1
  .Q:'$G(HLRX)
  .Q:'$D(^PSRX(HLRX,0))
@@ -27,31 +26,34 @@
  .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
  .I $G(PSODBQ) S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 Q
- .;   marked drug options 3 & 4
- .I (HLOSITE=3)!(HLOSITE=4) S NOTMD=0 D  Q:NOTMD     ;quit, not marked
- ..S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6)
- ..S:'$P($G(^PSDRUG(HLJUST,6)),"^") NOTMD=1
- .S HLRXY(II,HLRX)=""                                ;Valid Rx for HL7
- .S:HLOSITE=3 HLRXYZ(HLRX)=""
- ;
- I $G(HLOSITE)=3,$D(HLRXY) D                 ;rebuild PPL print string
- .K PPL F II=1:1 S HLRX=$P(PPLHL,",",II) Q:'HLRX  D
- ..Q:$D(HLRXYZ(HLRX))
- ..S PPL=$G(PPL)_HLRX_","
- ;
-SOMDQ S (II,PSOQUE)=0 F  S II=$O(HLRXY(II)) Q:'II  S ^UTILITY($J,"PSOHLL",II)=$O(HLRXY(II,0)),PSOQUE=II
- I PSOQUE=0 G ENDHL                ;Nothing set, bypass Call to Queue
- F II=0:0 S II=$O(^UTILITY($J,"PSOHLL",II)) Q:'II  S HLINRX=^(II),HLINRX0=$G(^PSRX(HLINRX,0)) D
- .S ^UTILITY($J,"PSOHLL",II)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
+ .;Here, if Site Parameter is 3, check entry in Drug File for National Id
+ .I $G(HLOSITE)=3 S HLJUST=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(HLJUST,6)),"^") Q
+ .S HLRXY(HLLOOP,HLRX)="" ; VALID RXS
+ .S:$G(HLOSITE)=3 HLRXYZ(HLRX)=""
+ I $G(HLOSITE)=3,$D(HLRXY) D
+ .N HLZFLAG,HLZ,HLZRX,HLZNEXT
+ .S HLZFLAG=0 K PPL F HLZ=1:1 S HLZRX=$P(PPLHL,",",HLZ) D  Q:$G(HLZFLAG)
+ ..S HLZNEXT=$P(PPLHL,",",(HLZ+1)) I HLZNEXT=""!(HLZNEXT=",") S HLZFLAG=1
+ ..Q:'$G(HLZRX)
+ ..Q:$D(HLRXYZ(HLZRX))
+ ..I $G(RXRP(HLZRX,"RP")) D  Q
+ ...I $G(PPL)="" S PPL=HLZRX_"," Q
+ ...S PPL=PPL_HLZRX_","
+ ..I $G(PPL)="" S PPL=HLZRX_"," Q
+ ..S PPL=PPL_HLZRX_","
+SOMDQ S HLCOT=1,PSHALP="" F  S PSHALP=$O(HLRXY(PSHALP)) Q:PSHALP=""  S ^UTILITY($J,"PSOHLL",HLCOT)=$O(HLRXY(PSHALP,0)),HLCOT=HLCOT+1
+ I HLCOT=1 G ENDHL ; NOTHING SET, BYPASS CALL TO QUEUE
+ F HLCOT=0:0 S HLCOT=$O(^UTILITY($J,"PSOHLL",HLCOT)) Q:'HLCOT  S HLINRX=^(HLCOT),HLINRX0=$G(^PSRX(HLINRX,0)) D
+ .S ^UTILITY($J,"PSOHLL",HLCOT)=HLINRX_"^"_+$P(HLINRX0,"^",6)_"^"_$S($G(RXPR(HLINRX)):"P",1:"F")
  .I '$G(RXPR(HLINRX)) S HLFOUR=0 F HHHH=0:0 S HHHH=$O(^PSRX(HLINRX,1,HHHH)) Q:'HHHH  I +^(HHHH,0) S HLFOUR=HHHH
  .I '$G(RXPR(HLINRX)),$G(RXFL(HLINRX))'="" S HLFOUR=$S($G(RXFL(HLINRX))=0:0,$D(^PSRX(HLINRX,1,+$G(RXFL(HLINRX)),0)):+$G(RXFL(HLINRX)),1:$G(HLFOUR))
- .S ^UTILITY($J,"PSOHLL",II)=^UTILITY($J,"PSOHLL",II)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG
- .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",II),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
- ..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL  S ^UTILITY($J,"PSOHLL",II,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1
- .S $P(^UTILITY($J,"PSOHLL",II),"^",6)=$S($G(HLINGF):1,1:0)
- .I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",II,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",II),"^",7)=1
- .E  S $P(^UTILITY($J,"PSOHLL",II),"^",7)=0
- .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
+ .S ^UTILITY($J,"PSOHLL",HLCOT)=^UTILITY($J,"PSOHLL",HLCOT)_"^"_$S($G(RXPR(HLINRX)):RXPR(HLINRX),1:HLFOUR)_"^"_$S($P($G(^PSRX(HLINRX,3)),"^",6)&('$G(RXPR(HLINRX)))&('$G(RXFL(HLINRX))):1,1:0) D ACLOG
+ .S HLINGF=0 I $P(^UTILITY($J,"PSOHLL",HLCOT),"^",5),$O(^PSRX(HLINRX,"DAI",0)) S HLINGF=1 D
+ ..F LL=0:0 S LL=$O(^PSRX(HLINRX,"DAI",LL)) Q:'LL  S ^UTILITY($J,"PSOHLL",HLCOT,HLINGF)=$G(^PSRX(HLINRX,"DAI",LL,0)),HLINGF=HLINGF+1
+ .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",6)=$S($G(HLINGF):1,1:0)
+ .I $D(^PSRX(HLINRX,"DRI")),'$G(RXPR(HLINRX)),'$G(RXFL(HLINRX)) S ^UTILITY($J,"PSOHLL",HLCOT,"DRI")=^PSRX(HLINRX,"DRI"),$P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=1
+ .E  S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",7)=0
+ .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=0 D RPT Q:'$G(^PSRX(HLINRX,"IB"))
  .I $P(^PSRX(HLINRX,"STA"),"^")>0,$P(^("STA"),"^")'=2,'$G(PSODBQ) Q
- .S $P(^UTILITY($J,"PSOHLL",II),"^",8)=1
+ .S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",8)=1
  ;
 AAA D STRT^PSOHLSG5
@@ -100,6 +102,6 @@
  Q
 RPT ;
- S $P(^UTILITY($J,"PSOHLL",II),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
- S $P(^UTILITY($J,"PSOHLL",II),"^",10)=+$G(PDUZ)
+ S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",9)=$S($G(PSOSUREP)!($G(RXRP(HLINRX))):1,1:0)
+ S $P(^UTILITY($J,"PSOHLL",HLCOT),"^",10)=+$G(PDUZ)
  Q
 SETZ ;
@@ -111,2 +113,15 @@
  D ^%ZTLOAD
  Q
+SOMD ;send only mark drugs to external interface and print in vista
+ S HLFLG=0 F HLLP=1:1 S HLRX=$P(PPLHL,",",HLLP) D  Q:$G(HLFLG)
+ .S HLNEXT=$P(PPLHL,",",(HLLP+1)) I HLNEXT=""!(HLNEXT=",") S HLFLG=1
+ .Q:'$G(HLRX)
+ .Q:'$D(^PSRX(HLRX,0))
+ .Q:$P($G(^PSRX(HLRX,"STA")),"^")=4
+ .I $P($G(^PSRX(HLRX,"STA")),"^")>11!('$P(^PSRX(HLRX,0),"^",2)) Q
+ .Q:$G(RXRP(HLRX,"RP"))
+ .S HLRR=$O(^PS(52.5,"B",HLRX,0)) Q:'HLRR  I $G(^PS(52.5,+HLRR,"P"))=1 K HLRR Q
+ .S DRG=+$P($G(^PSRX(HLRX,0)),"^",6) I '$P($G(^PSDRUG(DRG,6)),"^") Q
+ .S HLRXY(HLRX)="" ; VALID RXS
+ I $D(HLRXY) G SOMDQ
+ Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ;11/18/92
- ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233**;DEC 1997;Build 8
+PSOLBLN ;BIR/RTR-NEW PRINTS LABEL ; 3/11/07 1:56pm
+ ;;7.0;OUTPATIENT PHARMACY;**16,36,71,107,110,117,135,233,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^VA(200 supported by DBIA 224
@@ -19,4 +35,7 @@
  S TECH="("_$S($P($G(^PSRX(+$G(RX),"OR1")),"^",5):$P($G(^PSRX(+$G(RX),"OR1")),"^",5),1:$P(RXY,"^",16))_"/"_$S($G(VRPH)&($P(PSOPAR,"^",32)):VRPH,1:" ")_")"
  S PSZIP=$P(PS,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
+ ;
+ I $G(PSOAFYN)="Y" G PSOAFPL1 ;vfah
+ ;
 L1 W ?3,"VAMC ",$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP),?54,"VAMC ",$P(PS,"^",7),", ",STATE,"  ",$G(PSOHZIP),?102 W $S($D(REPRINT)&($G(PSOBLALL)):"(GROUP REPRINT)",$D(REPRINT):"(REPRINT)",1:"") W:$G(RXP) "(PARTIAL)"
  W !?3,$P(PS2,"^",2),"  ",$P(PS,"^",3),"-",$P(PS,"^",4),"   ",TECH,?54,$P(PS2,"^",2),"  ",$P(PS,"^",3),"-",$P(PS,"^",4),"   ",TECH,?102,$P(PS2,"^",2)," ",TECH," ",NOW
@@ -53,4 +72,7 @@
 L13 I $G(WARN)'="",'$G(PSOBLALL) I '$G(PSDFNFLG),'$G(PSOLAPPL) D WARN^PSOLBL2
  W @IOF
+ ;
+PSOAFPL1 I $G(PSOAFYN)="Y" D PSOAFP ;vfah
+ ;
 REP I COPIES>0 S SIDE=1 G ST
  D NOW^%DTC S NOW=% K %,%H,%I I $G(RXF)="" S RXF=0 F I=0:0 S I=$O(^PSRX(RX,1,I)) Q:'I  S RXF=I
@@ -65,10 +87,50 @@
  .S ^PSRX(RX,"L",IR,0)=NOW_"^"_$S($G(RXP):99-RXPI,1:RXF)_"^"_"ROUTING="_$G(MW)_" (BAD ADDRESS)"_"^"_PDUZ
  S ^PSRX(RX,"TYPE")=0 K RXF,IR,FDA,NOW,I,PCOMH(RX)
+PSOAFPL2 I $G(PSOAFYN)="Y" G PSOAFPL3 ;vfah
  I $G(WARN)'="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALLWARN^PSOLBLN1
  I $G(WARN)="" I $G(PSDFNFLG)!($G(PSOLAPPL)) D ALL^PSOLBLS
  I $G(PSOBLALL) D:$G(WARN)="" ALL^PSOLBLS D:$G(WARN)'="" ALLWARN^PSOLBLN1
  I '$D(PSSPND),$P(PSOPAR,"^",18) I $G(PSDFNFLG)!($G(PSOLAPPL))!($G(PSOBLALL)) D CHCK2^PSOTRLBL
+PSOAFPL3 ;vfah
  D:$G(PSOBLALL) TRAIL^PSOLBL2
 END ;
  I $D(RXFLX(RX)) S RXFL(RX)=$G(RXFLX(RX)) K RXFLX
+ ;
+ I '$D(REPRINT)&($G(PSOAFYN)="Y") D ^PSODISP ;vfah auto-release
+ ;
  D KILL^PSOLBL2 Q
+ ;
+ Q  ;vfah
+ ;
+PSOAFP ;Patient prescription print starts here;vfah
+ S PSOAFPRV=$P($G(^PSRX(RX,0)),"^",4)
+ S PSDU=$P($G(^PSDRUG($P($G(^PSRX(RX,0)),"^",6),660)),"^",8) ;vfah sets dispense units
+ I $G(VFASDD)="Y" S $P(^PSRX(RX,"RXFIN"),"^",1)="Y" ;Sets complex order flag in File#52
+ K VFASDD
+ ;
+AFFAX ;
+ I $G(REPRINT)'=1 D
+ .S LZ=0,STOP=0 F  S LZ=$O(^PSRX(RX,"PRC",LZ)) Q:'LZ!(STOP=1)  S LZZ=$P(^PSRX(RX,"PRC",LZ,0),"FAX: ",2) S LZZ=+LZZ I LZZ'=0 D
+ ..I $D(^DIZ(22900)) D
+ ...S DIC="^DIZ(22900,",DIC(0)="MOZ",X=LZZ
+ ...D ^DIC K DIC
+ ...I +Y'=-1 D
+ ....S PSOAFFXP=X
+ ....S PSOAFFXL=$P(Y,"^",2)
+ ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","+")
+ ....S STOP=1
+ ...I +Y=-1 D
+ ....S ^PSRX(RX,"PRC",LZ,0)=$TR(^PSRX(RX,"PRC",LZ,0),":","-")
+ K STOP,LZ,LZZ
+ I $G(REPRINT)=1 S PSOAFFXP=$G(PSOAFFXR)
+ I $G(PSOAFFXP)>1 G AFPTL
+ ;
+AFPTS I PSOLAP["STAR" D PRNT^PSOAFPTS
+ I PSOLAP["STAR" G AFKILL
+ I PSOLAP["STRL" D PRNT^PSOAFPT1
+ I PSOLAP["STRL" G AFKILL
+ ;
+AFPTL D BEGLP^PSOAFPTL
+ ;
+AFKILL K PSOAFPRV
+ I $G(REPRINT)'=1 D ^%ZISC
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLBLN2.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ;06/06/94
- ;;7.0;OUTPATIENT PHARMACY;**92,107,110**;DEC 1997
+PSOLBLN2 ;BHAM ISC/RTR - NEW LABEL TRAILER ; 11/12/06 8:02pm
+ ;;7.0;OUTPATIENT PHARMACY;**92,107,110,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  Q:'+$G(RXN)!('$G(PSOTRAIL))!('+$G(DFN))
  I $G(PSOBLALL),$P(PPL,",",PI+1)'="" Q
@@ -40,16 +56,17 @@
  .S ^TMP($J,"PSOSUSP",PSSPCNT)="  "_$$ZZ^PSOSUTL(PSSSRX) S PSSPCNT=PSSPCNT+1 K SPNUM,SPDATE,Y
 PRINT S PSOTRDFN=$P(VADM(2),"^"),PSOTRDFN=$S(PSOTRDFN]"":PSOTRDFN,1:"Unavailable") S Y=DT X ^DD("DD") S EDT=Y
- W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT
+ ;W ?54,VADM(1)_" "_$E($P(VADM(2),"^",2),5,12)_" "_EDT ;vfah
  W ! I PRCOPAY,$G(PSOBARS) S X="S",X2=PSOTRDFN,X1=$X W ?54,@PSOBAR1,PSOTRDFN,@PSOBAR0,$C(13) S $X=0
  I PRCOPAY,'$G(PSOBARS) W !!!
  I 'PRCOPAY W !
  I 'PSSUFLG D PRSUS G END
- S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH)  D
- .W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1
- .W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1
- .I PSNOADDR,PSNONARR S PSNOBOTH=1
+ ;S (PSNONARR,PSNOADDR,PSNOBOTH)=0 F TTT=1:1 Q:$G(PSNOBOTH)  D  ;vfah
+ ;.W $G(^TMP($J,"PSOMAIL",TTT)) S:'$O(^(TTT)) PSNOADDR=1 ;vfah
+ ;.W ?54,$G(^TMP($J,"PSONARR",TTT)),! S:'$O(^(TTT)) PSNONARR=1 ;vfah
+ ;.I PSNOADDR,PSNONARR S PSNOBOTH=1 ;vfah
 END K ^TMP($J,"PSONARR"),^TMP($J,"PSOMAIL"),^TMP($J,"PSOSUSP"),^UTILITY($J,"W")
  K DIWF,DIWL,DIWR,EDT,LLL,PRCOPAY,PS,PSNACNT,PSNOADDR,PSNOBOTH,PSNONARR,PSNOSUSP,PSNTHREE,PSOLGTH,PSOSD,PSOTRAIL,PSOTRDFN,PSSEVFL,PSSIXFL,PSSPCNT,PSSSRX,PSSUFLG,RXX,SPDATE,SPNUM,SPPL,STATE,TTT,VAADDR1,VADM,VAEL,VAPA,VASTREET,ZZ,ZZZ W @IOF
- I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
+ ;I $P(PSOPAR,"^",31) D BLANK^PSOLBLD W @IOF
+ I $P(PSOPAR,"^",31)="1" D BLANK^PSOLBLD W @IOF ;vfah
  Q
 PRSUS S (PSNONARR,PSNOADDR,PSNOSUSP,PSNTHREE)=0 F TTT=1:1 Q:$G(PSNTHREE)  D
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLLLI.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;4/25/07 9:00am
- ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200,206**;DEC 1997;Build 39
+PSOLLLI ;BIR/JLC - LASER LABELS INITIALIZATION ;10 Oct 2006  4:56 PM
+ ;;7.0;OUTPATIENT PHARMACY;**120,157,189,161,244,200**;DEC 1997;Build 7
  ;
  ;DBIAs PSDRUG-221, PS(55-2228, SC-10040, IBARX-125, PSXSRP-2201, %ZIS-3435, DPT-3097, ^TMP($J,"PSNPPIO"-3794
@@ -87,5 +87,5 @@
  S MAILCOM=""
  S X=$G(^PS(55,DFN,0)),PSCAP=$P(X,"^",2),PS55=$P(X,"^",3),PS55X=$P(X,"^",5)
- I PS55X]"",PS55>1,PS55X<DT S PS55=0
+ I PS55X]"",PS55>1,PS55X<DT S PS55=1
  S:MW="M" MW=$S((PS55=1!(PS55=4)):"R",1:MW)
  S MAILCOM=$P($G(^PS(59,PSOSITE,9)),"^")
@@ -94,5 +94,5 @@
  S DATE=$E(FDT,1,7),REF=$P(RXY,"^",9)-RXF S:'$G(RXP) $P(^PSRX(RX,3),"^")=FDT S:REF<1 REF=0 D ^PSOLBL2 S II=RX D ^PSORFL,RFLDT^PSORFL
  S (X,PSOFLAST)=$G(PSOLASTF) I X?1N.E D ^%DT X ^DD("DD") S PSOFLAST=Y
- S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["W")!(DEA[1)!(DEA[2) PRTFL=0
+ S PATST=$G(^PS(53,+$P(RXY,"^",3),0)) S PRTFL=1 I REF=0 S:('$P(PATST,"^",5))!(DEA["A"&(DEA'["B"))!(DEA["W") PRTFL=0
  S VRPH=$P(RX2,"^",10),PSCLN=+$P(RXY,"^",5),PSCLN=$G(^SC(PSCLN,0)),PSCLN=$S($P(PSCLN,"^",2)'="":$P(PSCLN,"^",2),1:$E($P(PSCLN,"^"),1,7)) I PSCLN="" S PSCLN="UNKNOWN"
  S PATST=$P(PATST,"^",2),X1=DT,X2=$P(RXY,"^",8)-10 D C^%DTC:REF I $D(^PSRX(RX,2)),$P(^(2),"^",6),REF,X'<$P(^(2),"^",6) S REF=0,VRPH=$P(^(2),"^",10)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLMPO.m	(revision 636)
@@ -1,6 +1,23 @@
-PSOLMPO ;ISC-BHAM/LC - pending orders ; 13-MAR-1995
- ;;7.0;OUTPATIENT PHARMACY;**46**;DEC 1997
+PSOLMPO ;ISC-BHAM/LC - pending orders ; 11/3/06 9:58pm
+ ;;7.0;OUTPATIENT PHARMACY;**46,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 EN ; -- main entry point for PSO LM PENDING ORDER
- S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMC
+ I $G(PSOAFYN)'="Y" S PSOLMC=0 D EN^VALM("PSO LM PENDING ORDER") K PSOLMCP ;vfam
+ I $G(PSOAFYN)="Y" D ACP^PSOORNEW ;vfam
  Q
  ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOLSET.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOLSET ;BHAM ISC/SAB - site parameter set up ;12/03/92
-VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247**;DEC 1997;Build 18
+PSOLSET ;BHAM ISC/SAB - site parameter set up ;3/13/07  19:50
+VERS ;;7.0;OUTPATIENT PHARMACY;**10,22,32,40,120,247,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference to ^PS(59.7 supported by DBIA 694
  ;Reference to ^PSX(550 supported by DBIA 2230
@@ -33,9 +49,29 @@
  .S %ZIS="MNQ",%ZIS("A")="Select PROFILE PRINTER: " S:$G(PSOCLBL)&($D(PSOPROP)) %ZIS("B")=PSOPROP
  .D ^%ZIS K %ZIS,IO("Q"),IOP Q:POP  S PSOPROP=ION D ^%ZISC
-LBL S %ZIS="MNQ",%ZIS("A")="Select LABEL PRINTER: " S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP)
+ S PSOAFIN=$P($G(^PS(59,PSOSITE,"RXFIN")),"^",1) ;vfah
+ S PSOAFPFX=$S(PSOAFIN="Y":"Select LABEL PRINTER or FAX DEVICE: ",1:"Select LABEL PRINT: ") ;vfah
+LBL S %ZIS="MNQ",%ZIS("A")=PSOAFPFX S:$G(PSOCLBL)&($D(PSOLAP))!($G(SUSPT)) %ZIS("B")=$S($G(SUSPT):PSLION,1:PSOLAP) ;vfah
  D ^%ZIS K %ZIS,IO("Q"),IOP S:POP PSOQUIT=1 G:POP EXIT S @$S($G(SUSPT):"PSLION",1:"PSOLAP")=ION,PSOPIOST=$G(IOST(0))
  N PSOIOS S PSOIOS=IOS D DEVBAR^PSOBMST
  S PSOBARS=PSOBAR1]""&(PSOBAR0]"")&$P(PSOPAR,"^",19),PSOIOS=IOS D ^%ZISC
 LASK I $G(PSOPIOST),$D(^%ZIS(2,PSOPIOST,55,"B","LL")) G EXIT
+ ;
+ ;vfah AutoFinish fax additions begin here
+ K PSOAFFXP,PSOAFFXL
+ I PSOLAP["FAX" D
+ .S PSOAFFXP="",PSOAFFXL="",PSOAFFXR=""
+ .S PSOLAP="AFFAX" D
+ ..S PSOION="" S PSOION=$O(^%ZIS(1,"B",PSOLAP,PSOION))
+ ..I $D(^DIZ(22900)) D
+ ...S DIC="^DIZ(22900,",DIC(0)="AEQMZ",DIC("A")="SEND FAX TO: "
+ ...D ^DIC K DIC
+ ...I Y=-1 W !,"Invalid selection" G LBL
+ ...S PSOAFFXL=$P(Y,"^",2)
+ ...S PSOAFFXP=$P($G(^DIZ(22900,+Y,3)),"^",3)
+ ...S PSOAFFXR=PSOAFFXP
+ ...I PSOAFFXL=""!(PSOAFFXP="") G LBL
+ I $G(PSOAFFXP)&(PSOLAP="AFFAX")'="" G EXIT
+ ;vfah Autofinish fax additions end here
+ ;
  K DIR S DIR("A")="OK to assume label alignment is correct",DIR("B")="YES",DIR(0)="Y",DIR("?")="Enter Y if labels are aligned, N if they need to be aligned." D ^DIR S:$D(DIRUT) PSOQUIT=1 G:Y!($D(DIRUT)) EXIT
 P2 S IOP=$G(PSOLAP) D ^%ZIS K IOP I POP W $C(7),!?5,"Printer is busy.",! G LASK
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOMAUEX.m	(revision 636)
@@ -1,8 +1,6 @@
-PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ; 10/10/07 11:17am
- ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148,257**;DEC 1997;Build 19
- ;;
+PSOMAUEX ;BIR/SAB-Auto expire of prescriptions ;10/10/96
+ ;;7.0;OUTPATIENT PHARMACY;**40,73,139,148**;DEC 1997
+ ;External reference to ^PS(59.7 is supported by DBIA 694
  ;External reference to STATUS^ORQOR2 is supported by DBIA 3458
- ;External reference to ^PS(59.7 is supported by DBIA 694
- ;External reference to LOCK1^ORX2 and UNLK1^ORX2 are supported by DBIA 867
  ;
  I '$G(DT) S DT=$$DT^XLFDT
@@ -23,6 +21,6 @@
  W !,"*******************************************************************************"
  W !!
- S ZZDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4))
- I 'ZZDT D  Q  ; V7.0 inst. dt not found, quit this job
+ S ZZIDT=$S($P($G(^PS(59.7,1,49.99)),"^",7):$P(^PS(59.7,1,49.99),"^",7),1:$P($G(^PS(59.7,1,49.99)),"^",4))
+ I 'ZZIDT D  Q  ; V7.0 inst. dt not found, quit this job
  .W !!!,"***** Outpatient installation date was not found, *****"
  .W !,"***** therefore this job cannot be run!!!!!       *****",!!
@@ -30,22 +28,18 @@
  ; - Ask for START DATE
  K %DT S %DT(0)=-DT,%DT="AEP",%DT("A")="Start Date: "
- S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZDT\1,-121))
+ S %DT("B")=$$FMTE^XLFDT($$FMADD^XLFDT(ZZIDT\1-121))
  W ! D ^%DT I Y<0!($D(DTOUT)) Q
- S ZZDT=Y
+ S ZZIDT=Y
  ;
  K %DT D NOW^%DTC S %DT="RAEX",%DT(0)=%,%DT("A")="Select the Date/Time to queue this job: "
  W ! D ^%DT K %DT I $D(DTOUT)!(Y<0) W !!!?10,"Job not queued!" Q
- S ZTDTH=$G(Y),ZTSAVE("ZZDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
+ S ZTDTH=$G(Y),ZTSAVE("ZZIDT")="",ZTIO="",ZTRTN="EN^PSOMAUEX",ZTDESC="Auto expire of Rxs "
  D ^%ZTLOAD
  W:$D(ZTSK) !!,"Task Queued !",!
  Q
-EN ;
- N PSOSVDT
- S PSOSVDT=""
- S X1=DT,X2=-1 D C^%DTC S CDT=X  ; setting the end date to to today-1
- F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT)  D EN1 S PSOSVDT=ZZDT
- I PSOSVDT>($P(^PS(59.7,1,49.99),"^",8)) D
- .S DIE=59.7,DA=1,DR="49.95///"_PSOSVDT D ^DIE K DIE,DA,DR
- K PSOEXRX,PSOEXSTA,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
+EN S X1=ZZIDT,X2=-121 D C^%DTC S ZZDT=X  ;setting the start date to 120 days before the install date
+ S X1=DT,X2=-1 D C^%DTC S CDT=X  ; setting the end date to todate-1
+ F  S ZZDT=$O(^PSRX("AG",ZZDT)) Q:'ZZDT!(ZZDT>CDT)  D EN1
+ K PSOEXRX,PSOEXSTA,ZZIDT,ZZDT,CDT,ORN,PIFN,PSUSD,PRFDT,PDA,PSDTEST S:$D(ZTQUEUED) ZTREQ="@"
  Q
 EN1 ;
@@ -55,9 +49,4 @@
  Q
 EN2 ;
-  N CPRSDC,CPRSSTA
- S CPRSDC=",1,7,12,13,"
- S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2),CPRSSTA=""
- I ORN S CPRSSTA=+$$STATUS^ORQOR2(ORN)
- S DA=PSOEXRX K CMOP D ^PSOCMOPA
  S DA=$O(^PS(52.5,"B",PSOEXRX,0))
  I DA,$P($G(^PS(52.5,DA,0)),"^",2),$P($G(^(0)),"^",3) S DIK="^PS(52.5," D ^DIK K DIK
@@ -65,37 +54,26 @@
  I $G(^PSRX(PSOEXRX,"H"))]"" K:$P(^PSRX(PSOEXRX,"H"),"^") ^PSRX("AH",$P(^PSRX(PSOEXRX,"H"),"^"),PSOEXRX) S ^PSRX(PSOEXRX,"H")=""
  S PSOEXSTA=$P($G(^PSRX(PSOEXRX,"STA")),"^")
+ I PSOEXSTA=11 D
+ .S $P(^PSRX(PSOEXRX,0),"^",19)=1
+ .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2)
+ .I ORN,+$$STATUS^ORQOR2(ORN)=6 D
+ ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
+ I (PSOEXSTA="")!(PSOEXSTA>9) Q
  ;
- I PSOEXSTA=11 S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I ORN I CPRSDC'[(","_CPRSSTA_",") D
- .S $P(^PSRX(PSOEXRX,0),"^",19)=1
- .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription is expired")
- ;
- I PSOEXSTA=13 D  Q
- .I 'ORN D EN^PSOHDR("PRES",PSOEXRX)
- ;
- I PSOEXSTA>9&(PSOEXSTA'=16) Q
- ;
- I +$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
+ ;get only those Rxs whoes status lies within 0 & 9
+ I PSOEXSTA?1N,+$P($G(^PSRX(PSOEXRX,2)),"^",6),+$P($G(^(2)),"^",6)<DT D
  .S $P(^PSRX(PSOEXRX,"STA"),"^")=11
+ .I $P($G(^PSRX(PSOEXRX,"OR1")),"^",2) D
+ ..D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
  .S (PIFN,PSUSD,PRFDT)=0
  .F  S PIFN=$O(^PSRX(PSOEXRX,1,PIFN)) Q:'PIFN  S PSUSD=PIFN,PRFDT=+$P($G(^PSRX(PSOEXRX,1,PIFN,0)),"^")
  .D REVERSE^PSOBPSU1(PSOEXRX,+PSUSD,"DE",5,"RX EXPIRED")
  .I $G(PSUSD),'$P($G(^PSRX(PSOEXRX,1,PSUSD,0)),"^",18) D EN3
- .S ORN=$P($G(^PSRX(PSOEXRX,"OR1")),"^",2) I 'ORN D EN^PSOHDR("PRES",PSOEXRX) Q
- .;If CPRS side already DC'd or expired, just send the expiration to the HDR
- .I CPRSDC[(","_CPRSSTA_",") D EN^PSOHDR("PRES",PSOEXRX) Q
- .S $P(^PSRX(PSOEXRX,0),"^",19)=1
- .D EN^PSOHLSN1(PSOEXRX,"SC","ZE","Prescription past expiration date")
  Q
 EN3 ;
  S (PSDTEST,PDA)=0 F  S PDA=$O(^PSRX(PSOEXRX,"L",PDA)) Q:'PDA  S:$P($G(^PSRX(PSOEXRX,"L",PDA,0)),"^",2)=PSUSD PSDTEST=1
  Q:PSDTEST
- I $G(CMOP(CMOP("L")))="",".L.X."[("."_$G(CMOP("S"))_".") S PSDTEST=1
- N PSOORL
- S PSOORL=$$LOCK1^ORX2(ORN) S:'PSOORL PSDTEST=1 I PSOORL D UNLK1^ORX2(ORN)
- N PDAQ,PDA0
- S PDAQ=0
- F PDA=0:0 S PDA=$O(^PSRX(PSOEXRX,4,PDA)) Q:'PDA  D
- .S PDA0=$G(^PSRX(PSOEXRX,4,PDA,0)) Q:PDA0=""
- .I $P(PDA0,"^",3)=PSUSD S PSDTEST=1
+ S DA=PSOEXRX K CMOP D ^PSOCMOPA
+ I $G(CMOP(CMOP("L")))="",$G(CMOP("S"))="L" S PSDTEST=1
 ENX I 'PSDTEST K ^PSRX(PSOEXRX,1,PSUSD),^PSRX("AD",PRFDT,PSOEXRX,PSUSD),^PSRX(PSOEXRX,1,"B",PRFDT,PSUSD) D NSET
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSON52.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSON52.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSON52.m	(revision 636)
@@ -1,9 +1,24 @@
 PSON52 ;BIR/DSD - files new entries in prescription file ;08/09/93
- ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,260**;DEC 1997;Build 84
+ ;;7.0;OUTPATIENT PHARMACY;**1,16,23,27,32,46,71,111,124,117,131,139,157,143,219,148,239,201,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference ^PS(55 supported by DBIA 2228
  ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
  ;External reference to ^XUSEC supported by DBIA 10076
  ;External reference SWSTAT^IBBAPI supported by DBIA 4663
- ;External reference SAVNDC^PSSNDCUT supported by DBIA 4707
 EN(PSOX) ;Entry Point
 START ;
@@ -66,4 +81,5 @@
  ;Next line, set SC question based on Copay status?
 IBQ ;I $G(PSOBILL)=2 S ^PSRX(PSOX("IRXN"),"IBQ")=$S($G(PSOX("NEWCOPAY")):0,1:1)
+ I $G(PSOAFYN)="Y" S PSOSCP="" ;vfah
  N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ("MST"))_"^"_$G(PSOANSQ("VEH"))_"^"_$G(PSOANSQ("RAD"))_"^"_$G(PSOANSQ("PGW"))_"^"_$G(PSOANSQ("HNC"))_"^"_$G(PSOANSQ("CV"))
  I PSOSCP<50&($TR(PSOSCFLD,"^")'="")&($P($G(^PS(53,+$G(PSONEW("PATIENT STATUS")),0)),"^",7)'=1) D
@@ -103,12 +119,9 @@
  ;
  ; - Calling ECME for claims generation and transmission / REJECT handling
- N ACTION,PSOERX
- S PSOERX=PSOX("IRXN")
- I $$SUBMIT^PSOBPSUT(PSOERX,0) D  I ACTION="Q"!(ACTION="^") Q
- . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,0,PSOX("FILL DATE"),"OF")
- . I $$FIND^PSOREJUT(PSOERX,0) D
- . . S ACTION=$$HDLG^PSOREJU1(PSOERX,0,"79,88","OF","IOQ","I")
- . I $$STATUS^PSOBPSUT(PSOERX,0)="E PAYABLE" D
- . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,0))
+ N ACTION
+ I $$SUBMIT^PSOBPSUT(PSOX("IRXN"),0) D  I ACTION="Q"!(ACTION="^") Q
+ . S ACTION="" D ECMESND^PSOBPSU1(PSOX("IRXN"),0,PSOX("FILL DATE"),"OF")
+ . I $$FIND^PSOREJUT(PSOX("IRXN"),0) D
+ . . S ACTION=$$HDLG^PSOREJU1(PSOX("IRXN"),0,"79,88","OF","IOQ","I")
  ;
 FINISHP ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEW.m	(revision 636)
@@ -1,4 +1,20 @@
-PSONEW ;BIR/SAB-new rx order main driver ;07/26/96
- ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268**;DEC 1997;Build 9
+PSONEW ;BIR/SAB-new rx order main driver ; 11/5/06 6:35pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,94,130,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references L and UL^PSSLOCK supported by DBIA 2789
  ;External reference to ^VA(200 supported by DBIA 224
@@ -65,10 +81,12 @@
 COUN ;patient counseling
  G:$G(PSORX("EDIT"))&('$G(PSOSIGFL)) NOORX K DIR,DUOUT,DTOUT,DIRUT
- S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0)
+ I $G(PSOAFYN)'="Y" S DIR("B")="NO",DIR(0)="52,41" D ^DIR S PSOCOU=$S(Y:Y,1:0) ;vfam
+ I $G(PSOAFYN)="Y" S PSOCOU=0 ;vfam No Patient Counseling by AutoFinihs
  I $D(DIRUT)!('PSOCOU) S PSOCOUU=0 D:'$G(SPEED) PRONTE Q
  K:'$G(PSOCOU) PSOCOUU K DIR,DUOUT,DTOUT,DIRUT I Y S DIR(0)="52,42",DIR("B")="NO" D ^DIR S PSOCOUU=$S(Y:Y,1:0)
 PRONTE K PSONOTE,DIR,DIRUT,DUOUT
  I $T(MAIN^TIUEDIT)]"",'$G(SPEED) D  K DIR,DIRUT,DUOUT
- .S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR
+ .I $G(PSOAFYN)'="Y" S DIR(0)="Y",DIR("B")="No",DIR("A")="Do you want to enter a Progress Note",DIR("A",1)="" D ^DIR K DIR ;vfam
+ .I $G(PSOAFYN)="Y" S Y="0" ;vfam No Progress Notes in AutoFinish
  .S PSONOTE=+Y Q  ;I 'Y!($D(DIRUT)) Q
 NOORX K X,Y,DIR,DUOUT,DTOUT,DIRUT
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSONEWF.m	(revision 636)
@@ -1,6 +1,23 @@
 PSONEWF ;BIR/RTR - Copay finish questions ;07/26/96
- ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239**;DEC 1997
+ ;;7.0;OUTPATIENT PHARMACY;**71,157,143,219,226,239,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference VADPT supported by DBIA 10061
 START ;
+ I $G(PSOAFYN)="Y" Q  ; vfam
  N PSOPENIB,PSOSCOTH,PSOSCOTX,PSOMESFI
  S PSOPENIB=$S($G(ORD):$G(^PS(52.41,+$G(ORD),"IBQ")),1:"")
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOORAL ;BHAM-ISC/SAB - activity log list ; 28-APR-1995
- ;;7.0;OUTPATIENT PHARMACY;**148,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148**;DEC 1997
 EN ; -- main entry point for PSO LM ACTIVITY LOGS
  D EN^VALM("PSO LM ACTIVITY LOGS")
@@ -10,5 +10,5 @@
  ;
 INIT ; -- init variables and list array
- I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT")!($G(PS)="REJECTMP") D
+ I $G(PS)="VIEW"!($G(PS)="DELETE")!($G(PS)="REJECT") D
  .I ST<12,$P(RX2,"^",6)<DT S ST=11
  .S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORAL1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOORAL1 ;BHAM ISC/SAB - Build Listman activity logs ; 12/4/07 12:25pm
- ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247,240**;DEC 1997;Build 5
+PSOORAL1 ;BHAM ISC/SAB - Build Listman activity logs ;11/16/92 13:11
+ ;;7.0;OUTPATIENT PHARMACY;**71,156,148,247**;DEC 1997;Build 18
  N RX0,VALMCNT K DIR,DTOUT,DUOUT,DIRUT,^TMP("PSOAL",$J) S DA=$P(PSOLST(ORN),"^",2),RX0=^PSRX(DA,0),J=DA,RX2=$G(^(2)),R3=$G(^(3)),CMOP=$O(^PSRX(DA,4,0))
  S IEN=0,DIR(0)="LO^1:"_$S(CMOP:8,1:7),DIR("A",1)=" ",DIR("A",2)="Select Activity Log by  number",DIR("A",3)="1.  Refill      2.  Partial      3.  Activity     4.  Labels"
@@ -34,10 +34,11 @@
  .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
  ..S PSOACBRV=$P(P1,"^",5)
- ..;PSO*7*240 Use fileman for parsing
- ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0))
+ ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
+ ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q
+ ..F PSOACBRK=245:-1 Q:PSOACBRK=0  I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q
  .I $P($G(^PSRX(DA,"A",N,1)),"^")]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P($G(^PSRX(DA,"A",N,1)),"^") I $P($G(^PSRX(DA,"A",N,1)),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P($G(^PSRX(DA,"A",N,1)),"^",2)
  .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I  S MIG=^PSRX(DA,"A",N,2,I,0) D
  ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
- K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR
+ K MIG,SG,I
  Q
 LBL ;label log
@@ -84,6 +85,7 @@
  .I $P(P1,"^",5)]"" D
  ..S PSOACBRV=$P(P1,"^",5)
- ..;PSO*7*240 Use fileman for parsing
- ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0))
+ ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
+ ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q
+ ..F PSOACBRK=245:-1 Q:PSOACBRK=0  I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q
  .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(DA,"A",N,2,I)) Q:'I  S MIG=^PSRX(DA,"A",N,2,I,0) D
  ..F SG=1:1:$L(MIG) D
@@ -91,5 +93,4 @@
  ...S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
  D DISPREJ
- K ^UTILITY($J,"W"),DIWR,DIWF,DIWL
  Q
  ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;5/10/07 8:25am
- ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268,206**;DEC 1997;Build 39
+PSOORED1 ;ISC-BHAM/SAB - edit orders from backdoor ;6/30/06 10:21am
+ ;;7.0;OUTPATIENT PHARMACY;**5,23,46,78,114,117,131,146,223,148,244,249,268**;DEC 1997;Build 9
  ;External reference ^PS(55 supported by DBIA 2228
  ;External reference ^PS(50.7 supported by DBIA 2223
@@ -131,5 +131,5 @@
  .S PSOX1=PTRF,PSOX=$S(PSOX1=11:11,1:PSOX1),PSOX=$S('PSOX:0,PSDAYS=90:3,1:PSOX)
  .S PSDY1=$S(PSDAYS<60:11,PSDAYS'<60&(PSDAYS'>89):5,PSDAYS=90:3,1:0) S PSORENW("# OF REFILLS")=$S(PSOX'>PSDY1:PSOX,1:PSDY1)
- I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSORENW("# OF REFILLS")=0
+ I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSORENW("# OF REFILLS")=0
  K PSDY,PSDY1,PTRF,PSOX,PSOX1,PSDAYS,CS
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED2.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOORED2 ;ISC-BHAM/SAB-edit orders from backdoor con't ;03/06/95 10:24
- ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**2,51,46,78,102,114,117,133,159,148,247,260**;DEC 1997;Build 84
  ;Reference to $$DIVNCPDP^BPSBUTL supported by IA 4719
  ;Reference to $$ECMEON^BPSUTIL supported by IA 4410
@@ -52,9 +52,8 @@
  D GETS^DIQ(52.1,DA_","_DA(1)_",",".01;1;1.1;8;11;81","I","FLDS")
  S:$D(^PSRX(DA(1),1,DA,0)) PSORXED("RX1")=^PSRX(DA(1),1,DA,0),(RFED,RFL)=DA
- I $G(ST)=11!($G(ST)=12),$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" S QUIT=0 D RFE Q  ;short circuit for DC'd/Expired ECME RXs
  D ^DIE S QUIT=$D(Y) K FEV,RFN,RFM,X,Y,DR
  I '$G(DA) D REVERSE^PSOBPSU1(PSORXED("IRXN"),RFL,"DE",5) K CMRL,RFED D:$D(PSORX("PSOL"))&($G(DI)=.01) RFD Q
  I 'CMRL,'QUIT S DR="1;1.2:5;8" D ^DIE S QUIT=$D(Y)
-RFE I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
+ I '$D(^PSRX(PSORXED("IRXN"),1,RFL)) Q
  I 'QUIT,$$STATUS^PSOBPSUT(PSORXED("IRXN"),RFL)'="" D
  . S NDC=$$GETNDC^PSONDCUT(PSORXED("IRXN"),RFL)
@@ -74,5 +73,5 @@
  . . D ECMESND^PSOBPSU1(RX,RFL,,"ED",$$GETNDC^PSONDCUT(RX,RFL),,$S($P(CHANGED,"^",2):"REFILL DIVISION CHANGED",1:"REFILL EDITED"),,+$G(CHGNDC))
  . . ;- Checking/Handling DUR/79 Rejects
- . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","Q")
+ . . I $$FIND^PSOREJUT(RX,RFL) S X=$$HDLG^PSOREJU1(RX,RFL,"79,88","ED","IOQ","I")
  K DIE,CMRL,DA,DR
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED6.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOORED6 ;BIR/SAB - edit orders from backdoor ;03/06/96
- ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260,269**;DEC 1997;Build 4
+ ;;7.0;OUTPATIENT PHARMACY;**78,104,117,133,143,219,148,247,268,260**;DEC 1997;Build 84
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^PS(50.7 supported by DBIA 2223
@@ -52,7 +52,5 @@
  S DIC("B")=$P(^PS(50.7,PSOI,0),"^"),DIC="^PS(50.7,",DIC(0)="AEMQZ"
  S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F  S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL  "
- S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
- ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
- S D="B^C" D MIX^DIC1 I "^"[X S PSORXED("DFLG")=1 Q
+ S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1" D ^DIC I "^"[X S PSORXED("DFLG")=1 Q
  G:Y<1 PSOI Q:PSOI=+Y
  S PSODRUG("OI")=+Y,PSODRUG("OIN")=Y(0,0) K DIC
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED7.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED7.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORED7.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOORED7 ;ISC-BHAM/MFR-edit orders from backdoor con't ;03/06/95 10:24
- ;;7.0;OUTPATIENT PHARMACY;**148,247,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,247**;DEC 1997;Build 18
  ;called from psooredt. cmop edit checks.
  ;Reference to file #50 supported by IA 221
@@ -59,5 +59,5 @@
  . . D ECMESND^PSOBPSU1(RX,0,,"ED",$$GETNDC^PSONDCUT(RX,0),,$S($P(CHANGED,"^",2):"RX DIVISION CHANGED",1:"RX EDITED"),,+$G(CHGNDC))
  . . ;- Checking/Handling DUR/79 Rejects
- . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","Q")
+ . . I $$FIND^PSOREJUT(RX,0) S X=$$HDLG^PSOREJU1(RX,0,"79,88","ED","IOQ","I")
  Q
  ;
@@ -72,35 +72,2 @@
  I $$DIVNCPDP^BPSBUTL(+$G(PRIOR(52,RX_",",20,"I")))'=$$DIVNCPDP^BPSBUTL(+$G(SAVED(52,RX_",",20,"I"))) S CHANGED="1^1"
  Q CHANGED
- ;;
-NDCDAWDE(ST,FLN,RXN) ; allow edit of NDC & DAW for DC'd/expired ECME RXs
- ;;  input: (r) ST  - the Rx status code
- ;;         (r) FLN - field number selected for editing
- ;;         (r) RXN - prescription #
- ;; output: VALMSG for inappropriate field selection or use
- ;;         PSODRUG & RSORXED arrays updated if edited
- Q:$G(ST)=""!($G(FLN)="")!($G(RXN)="")
- I '((ST=11)!(ST=12)) S VALMSG=("Invalid selection!") Q
- I '((FLN=2)!(FLN=20)!(FLN=21)) S VALMSG=("Invalid selection!") Q
- I $$STATUS^PSOBPSUT(RXN,$$LSTRFL^PSOBPSU1(RXN))="" S VALMSG=("Invalid selection!") Q
- ;
- ; edit NDCs
- I FLN=2 D  Q
- .N NDC
- .S NDC=$$GETNDC^PSONDCUT(RXN,0)
- .D NDCEDT^PSONDCUT(RXN,"",$G(DRG),$G(PSOSITE),.NDC)
- .I $G(NDC)="^" Q
- .S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
- ;;
- ; edit refill NDCs/DAWs
- I FLN=20 D  Q
- .I $$LSTRFL^PSOBPSU1(RXN)=0 S VALMSG="Invalid selection!" Q
- .D REF^PSOORED2
- ;;
- ; edit DAW
- I FLN=21 D  Q
- .N DAW
- .D EDTDAW^PSODAWUT(RXN,0,.DAW)
- .I $G(DAW)="^" Q
- .S (PSODRUG("DAW"),PSORXED("FLD",81))=DAW
- Q
- ;;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOOREDT.m	(revision 636)
@@ -1,4 +1,12 @@
-PSOOREDT ;BIR/SAB - edit orders from backdoor ;03/06/96
- ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,260,281**;DEC 1997;Build 41
+PSOOREDT ;BIR/SAB - edit orders from backdoor ;1/27/07  13:22
+ ;;7.0;OUTPATIENT PHARMACY;**4,20,27,37,57,46,78,102,104,119,143,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to PSSLOCK supported by DBIA 2789
@@ -38,6 +46,5 @@
  Q
  ;
-EDT ; Rx Edit (Backdoor)
- K NCPDPFLG
+EDT S NCPDPFLG=0
  S I=0 F  S I=$O(^PSRX($P(PSOLST(ORN),"^",2),1,I)) Q:'I  S PSORXED("RX1")=^PSRX($P(PSOLST(ORN),"^",2),1,I,0)
  S (RX0,PSORXED("RX0"))=^PSRX($P(PSOLST(ORN),"^",2),0),PSORXED("RX2")=$G(^(2)),PSORXED("RX3")=$G(^(3)),PSOSIG=$P(^("SIG"),"^")
@@ -52,9 +59,8 @@
  .D:'$G(CHK) POP^PSOSIGNO(DA),CHK Q:$G(PSORXED("DFLG"))
  .S FDR="39.2^"_$S($P(PSOPAR,"^",3):"6",1:"")_";6.5^113^114^3^1^22R^24^8^7^9^4^11;"_$S($P(RX0,"^",11)="W"&($P(PSOPAR,"^",12)):"35;",1:"")_"^10.6^5^20^23^12^PSOCOU^RF^81"
- .I $G(ST)=11!($G(ST)=12) D NDCDAWDE^PSOORED7(ST,FLN,$G(RXN)) Q
  .I FLN=20,'$G(REF) S VALMSG="There is no Refill Data to be edited." Q
  .S DR=$P(FDR,"^",FLN) I DR="RF" D REF^PSOORED2 Q
  .I DR="PSOCOU" D PSOCOU^PSOORED6 Q
- .I FLN=2,'$P(PSOPAR,"^",3),$$RXRLDT^PSOBPSUT(RXN,0),$$STATUS^PSOBPSUT(RXN,0)'="" D  Q
+ .I FLN=2,'$P(PSOPAR,"^",3) D  Q
  ..N NDC D NDC^PSODRG(RXN,0,,.NDC) I $G(NDC)="^"!($G(NDC)="") Q
  ..S (PSODRUG("NDC"),PSORXED("FLD",27))=NDC
@@ -100,4 +106,10 @@
  ;
  I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=14!($P(^("STA"),"^")=15) S PSORXED("DFLG")=1 S VALMSG="Discontinued prescriptions cannot be edited." Q
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P($G(^PSRX(PSORXED("IRXN"),"OR1")),"^",5)=$G(PSOZAF) S PSORXED("DFLG")=1 S VALMSG="EDIT option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
+ ;
  I $P(^PSRX(PSORXED("IRXN"),"STA"),"^")=16 S PSORXED("DFLG")=1 S VALMSG="Prescriptions on Provider Hold cannot be edited." Q
 CHKX K PSPOP,DIR,DTOUT,DUOUT,Y,X Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI1.m	(revision 636)
@@ -1,4 +1,6 @@
-PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;5/23/05 2:11pm
- ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,260**;DEC 1997;Build 84
+PSOORFI1 ;BIR/SAB - finish OP orders from OE/RR continued ;1/27/07  13:24
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,32,44,51,46,71,90,108,131,152,186,210,222,258,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;Ref. ^PS(50.7 supp. DBIA 2223
  ;Ref. ^PSDRUG( supp. DBIA 221
@@ -15,4 +17,5 @@
  S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
  I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR G DRG
+ I '$P(OR0,"^",9)&($G(PSOAFYN)="Y") D DISPD^PSOAFIN G DSPL ;vfah 060924
  I '$P(OR0,"^",9) D DREN^PSOORNW2
 DRG I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),"CLOZ1")),"^")="PSOCLO1" D CLOZ^PSOORFI2
@@ -72,5 +75,5 @@
  . I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11)) Q
  .S PSONEW("# OF REFILLS")=+$P(OR0,"^",11)
- S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" (  )")_": "
+ S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"                (9)   QTY"_$S($P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)]"":" ("_$P($G(^PSDRUG(+$G(PSODRUG("IEN")),660)),"^",8)_")",1:" (  )")_": "_$P(OR0,"^",10)
  S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_$S($D(CLOZPAT):+$G(PSONEW("QTY")),1:$P(OR0,"^",10))
  I $P($G(^PSDRUG(+$G(PSODRUG("IEN")),5)),"^")]"" D
@@ -92,10 +95,9 @@
  S Y=$P(OR0,"^",12) X ^DD("DD") S ^TMP("PSOPO",$J,IEN,0)=^TMP("PSOPO",$J,IEN,0)_"Entry Date: "_$E($P(OR0,"^",12),4,5)_"/"_$E($P(OR0,"^",12),6,7)_"/"_$E($P(OR0,"^",12),2,3)_" "_$P(Y,"@",2) K RN
  S PSOACT=$S($D(^XUSEC("PSORPH",DUZ)):"DEF",'$D(^XUSEC("PSORPH",DUZ))&($P($G(PSOPAR),"^",2)):"F",1:"")
- ; - PSOACTOV is used to force the Pending Order to be Read-Only (no updates) even if invoked by a Pharmacist
- I $G(PSOACTOV) S PSOACT=""
  D:'$G(ACP) EN^PSOLMPO S:$G(ACP) VALMBCK="Q" D:$G(PKI1)=2 DCP^PSOPKIV1
  Q
 POST ;post patient selection
- D POST^PSOORFI2 Q
+ I $G(PSOAFYN)'="Y" D POST^PSOORFI2 Q  ;vfah
+ I $G(PSOAFYN)="Y" Q  ;vfah
 SIG ;displays possible sig
  D SIG^PSOORFI2 Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI2.m	(revision 636)
@@ -1,6 +1,8 @@
-PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;07/29/96
- ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222**;DEC 1997;Build 12
- ;External reference ^YSCL(603.01 supported by DBIA 2697
- ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
+PSOORFI2 ;BIR/BHW-finish cprs orders cont. ;1/27/07  13:25
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,23,27,46,130,146,177,222,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
+ ;Ext ref ^YSCL(603.01 supported by DBIA 2697
+ ;Ext refs PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 HLP W !,"Enter 'S' to process orders with a priority of STAT",!,"      'E' to process orders with an Emergency priority,",!,"      'R' to process Routine orders.",! Q
 HELP ;
@@ -20,18 +22,24 @@
  .I $P($G(^PS(52.41,PSZFZZ,0)),"^",3)="NW"!($P($G(^(0)),"^",3)="RNW")!($P($G(^(0)),"^",3)="RF") I $P($G(^PS(52.41,PSZFZZ,"INI")),"^")=$G(PSOPINST) S PSZFIN=0
  Q
-PROFILE ;display med profile
- S MEDA=3 ;3=question asked already
- W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y)
- I Y S MEDP=1
+PROFILE ;
+ S MEDA=3
+ I $G(PSOAFYN)'="Y" W !!! K MEDP,DIR,DUOUT,DIRUT,DTOUT S DIR(0)="Y",DIR("B")="Yes",DIR("A")="Do you want to see Medication Profile" D ^DIR K DIR Q:$D(DIRUT)!('Y)
+ I $G(PSOAFYN)'="Y" I Y S MEDP=1
+ I $G(PSOAFYN)="Y" K MEDP
  K DIR,DUOUT,DIRUT,DTOUT
  Q
 DC I '$G(PSOORRNW),$G(PSOOPT)=3 S PSORENW("DFLG")=1 S:'$D(PSOBBC1("FROM")) VALMBCK="Q",VALMSG="Renew Rx Request Canceled.",Y=-1 Q
- N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)
+ I $G(PSOAFYN)'="Y" N VALMCNT W ! K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)
  .D NOOR^PSOCAN4 Q:$D(DIRUT)
  .S DIR("A")="Comments",DIR(0)="F^10:75",DIR("B")="Per Pharmacy Request" D ^DIR K DIR
+ I $G(PSOAFYN)="Y" N VALMCNT K DIR,DUOUT,DIROUT,DTOUT,PSOELSE I '$G(PSOERR("DEAD")) S PSOELSE=1 D  Q:$D(DIRUT)  ;vfah
+ .D NOOR^PSOCAN4 Q:$D(DIRUT)  ;vfah
+ .S Y="Rx AutoFinish" ;vfah
+ I $G(PSOAFYN)'="Y" S PSOELSE="1"
  I '$G(PSOELSE) K PSOELSE S PSONOOR="A" G DE
  K PSOELSE I $D(DIRUT) K DIRUT,DUOUT,DTOUT,Y Q
  S ACOM=Y
-DE Q:'$D(^PS(52.41,ORD,0))
+DE I $G(PSOAFYN)="Y" Q
+ I $G(PSOAFYN)'="Y" Q:'$D(^PS(52.41,ORD,0))
  K ^PS(52.41,"AOR",$P(^PS(52.41,ORD,0),"^",2),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD),^PS(52.41,"AD",$P(^PS(52.41,ORD,0),"^",12),+$P($G(^PS(52.41,ORD,"INI")),"^"),ORD)
  S $P(^PS(52.41,ORD,0),"^",3)="DC",POERR("PLACER")=$P(^(0),"^"),POERR("STAT")="OC"
@@ -42,5 +50,5 @@
  S Y=-1 Q
  ;
-RF ;process refill request from CPRS
+RF ;
  S PSOREF("IRXN")=$P(OR0,"^",19) D PSOL^PSSLOCK($P(OR0,"^",19)) I '$G(PSOMSG) D  D PAUSE^VALM1 K PSOREF,PSOMSG Q
  .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2),! Q
@@ -52,11 +60,7 @@
  S PSONEW("DAYS SUPPLY")=$P(^PSRX(PSOREF("IRXN"),0),"^",8),PSONEW("# OF REFILLS")=$P(^(0),"^",9) D FULL^VALM1
  W !!,"Processing Refill Request for Rx "_$P(^PSRX(PSOREF("IRXN"),0),"^")
- ;S:$G(PSOREQFD)]"" PSORX("FILL DATE")=PSOREQFD
  D FILLDT^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
- ;S:$G(PSORX("FILL DATE"))]"" PSOREQFD=PSORX("FILL DATE")
  ;
- ;S:$G(PSOREQMP)]"" PSORX(" METHOD OF PICK-UP")=PSOREQMP
  S PSORX("MAIL/WINDOW")=$S($P(OR0,"^",17)="M":"MAIL",1:"WINDOW") D MW^PSODIR2(.PSOREF) I PSOREF("DFLG") S VALMBCK="R" G END
- ;S:$G(PSORX("METHOD OF PICK-UP"))]"" PSOREQMP=PSORX("METHOD OF PICK-UP")
  S:'$G(PSOFROM)'="NEW" PSOFROM="REFILL" S PSOREF("DFLG")=0
  D ^PSOREF0
@@ -88,8 +92,9 @@
 KPRIZ K PSOQUIT,POERR("QFLG")
  Q
-INST ;Select Institution
+INST ;
  I '$G(PSOSITE) D ^PSOLSET I '$G(PSOSITE) S PSOIQUIT=1 Q
  N PSIR,PSCT,PSINST K PSOPINST
- S PSCT=0 F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSCT=PSCT+1 I PSCT=1 S PSOPINST=$P($G(^(0)),"^")
+ I $G(PSOAFYN)="Y" S PSCT=1,PSOPINST=+ORL ;vfah selects CPRS Ordering Institution if autofinishing and non-interactive
+ I $G(PSOAFYN)'="Y" S PSCT=0 F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSCT=PSCT+1 I PSCT=1 S PSOPINST=$P($G(^(0)),"^") ;vfah
  I PSCT=0 W !!,"There are no CPRS Ordering Institutions associated with this Outpatient site!",!,"Use the Site Parameter enter/edit option to enter CPRS Ordering Institutions!",! S PSOIQUIT=1 Q
  I PSCT=1 Q
@@ -104,5 +109,5 @@
  F PSIR=0:0 S PSIR=$O(^PS(59,PSOSITE,"INI1",PSIR)) Q:'PSIR!($G(PSOPINST))  I $P($G(^PS(59,PSOSITE,"INI1",PSIR,0)),"^") S PSOPINST=$P($G(^(0)),"^")
  Q
-CLOZ ;checks clozapine status of patient 
+CLOZ ;
  S CLOZPAT=$O(^YSCL(603.01,"C",PSODFN,0))
  S CLOZPAT=$P($G(^YSCL(603.01,+CLOZPAT,0)),"^",3)
@@ -113,5 +118,5 @@
  I $G(CLOZPAT)=2 S IEN=IEN+1,^TMP("PSOPO",$J,IEN,0)="   Patient Eligible for 28 Day Supply or 14 Day Supply with 1 refill or 7 Day Supply with 3 refill"
  Q
-USER(USER) ;returns .01 of 200
+USER(USER) ;
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="M",X="`"_USER D ^DIC S USER1=$S(+Y:$P(Y,"^",2),1:"Unknown") K DIC,X,Y
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI3.m	(revision 636)
@@ -1,4 +1,6 @@
-PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;11/09/98
- ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172**;DEC 1997
+PSOORFI3 ;BIR/RTR-finish CPRS orders by Clinic ;5/14/07  10:07
+ ;;7.0;OUTPATIENT PHARMACY;**15,27,32,46,84,99,130,117,139,172,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;PPPPDA1-1374,SC(-2675,40.8-728,51.2-2226,50.607-2221,55-2228,PSSLOCK-2789,DPT-10035,ORX2-867
  ;
@@ -58,5 +60,5 @@
 L1 ;Lock single order
  I '$G(ORD) Q
- K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
+ K PSOMSG D PSOL^PSSLOCK(+ORD_"S") I '$G(PSOMSG),'$D(ZTSK) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"This Order is being edited by another person."),! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR
  Q
 UL1 ;Unlock single order
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFI4.m	(revision 636)
@@ -1,4 +1,6 @@
-PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ; 6/28/07 7:36am
- ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,274**;DEC 1997;Build 8
+PSOORFI4 ;BIR/SAB-CPRS order checks and display con't ;1/27/07  13:26
+ ;;7.0;OUTPATIENT PHARMACY;**46,74,78,99,117,131,207,258,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;External reference to ^PS(51.2 supported by DBIA 2226
  ;External reference to ^PS(50.607 supported by DBIA 2221
@@ -30,15 +32,16 @@
  .D EN^DDIOL("Provider Comments: ","","!")
  .F I=0:0 S I=$O(PRC(I)) Q:'I  D EN^DDIOL(PRC(I),"","!")
- .D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"
- .D ^DIR Q:'Y!($D(DIRUT))
+ .I $G(PSOAFYN)="Y" D KV^PSOVER1 ;vfam
+ .I $G(PSOAFYN)'="Y" D KV^PSOVER1 S DIR(0)="Y",DIR("A")="Copy Provider Comments into the Patient Instructions",DIR("B")="No"  ;vfam
+ .I $G(PSOAFYN)'="Y" D ^DIR Q:'Y!($D(DIRUT))  ;vfam
+ .I $G(PSOAFYN)="Y" Q  ;vfam Provider Comments NOT Copied Into Patient Instructions
  .S PSOPRC=1,NI=0 F I=0:0 S I=$O(PSONEW("SIG",I)) Q:'I  S NI=I
  .S NC=0 F I=0:0 S I=$O(PRC(I)) Q:'I  S NC=NC+1
- .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q 
- ..S X=PRC(1) D SIGONE^PSOHELP
- ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_INS1 K INS1,X
+ .I NI'>1,NC=1,($L($G(PSONEW("SIG",NI)))+$L(PRC(1)))'>250 D  Q
+ ..S PSONEW("SIG",1)=$G(PSONEW("SIG",NI))_" "_PRC(1)
  ..S:$E(PSONEW("SIG",1))=" " PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250) S PSONEW("INS")=PSONEW("SIG",1) D EN^PSOFSIG(.PSONEW,1) K NI,NC
- .F I=0:0 S I=$O(PRC(I)) Q:'I  S NI=NI+1,(PSONEW("INS",NI),X)=PRC(I) D SIGONE^PSOHELP S PSONEW("SIG",NI)=INS1 K INS1
+ .F I=0:0 S I=$O(PRC(I)) Q:'I  S NI=NI+1,(PSONEW("SIG",NI),PSONEW("INS",NI))=PRC(I)
  .I $E(PSONEW("SIG",1))=" " S PSONEW("SIG",1)=$E(PSONEW("SIG",1),2,250)
- .D EN^PSOFSIG(.PSONEW,1) K NI,NC,X
+ .D EN^PSOFSIG(.PSONEW,1) K NI,NC
  Q
 DOSE ;displays dosing info for pending orders.  called from psoorfi1
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORFIN.m	(revision 636)
@@ -1,13 +1,20 @@
-PSOORFIN ;BIR/SAB-finish cprs orders ;12/21/04 3:24pm
- ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195**;DEC 1997
+PSOORFIN ;BIR/SAB-finish cprs orders ;5/14/07  09:47
+ ;;7.0;OUTPATIENT PHARMACY;**7,15,27,32,44,46,84,106,111,117,131,146,139,195,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) GNU GPL 2007 WorldVistA
+ ;
  ;PSSLOCK-2789,PSDRUG-221,50.7-2223,55-2228,50.606-2174
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX
+ I $G(PSOAFYN)'="Y" D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) D MSG^PSODPT G EX ;vfah
+ I $G(PSOAFYN)="Y" D:'$D(PSOPAR) ^PSOAFSET I '$D(PSOPAR) D MSG^PSODPT G EX  ;vfah
  D INST^PSOORFI2 I $G(PSOIQUIT) K PSOIQUIT G EX
  I $P($G(PSOPAR),"^",2),'$D(^XUSEC("PSORPH",DUZ)) S PSORX("VERIFY")=1
- S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;E:EXIT" D ^DIR I $D(DIRUT)!(Y="E") G EX
+ I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ S DIR("?")="^D ST^PSOORFI1",DIR("A")="Select By",DIR("B")="PATIENT",DIR(0)="SMB^PA:PATIENT;RT:ROUTE;PR:PRIORITY;CL:CLINIC;E:EXIT" D ^DIR I $D(DIRUT)!(Y="E") G EX ;vfah
+ I $G(PSOAFYN)'="Y" S (PSOFIN,POERR)=1 K PSOBCK,MEDA,MEDP,SRT,DIR D KQ ;vfah
+ I $G(PSOAFYN)="Y" S Y="PA" ;vfah
  G:Y="PA" PAT G:Y="PR" PRI G:Y="CL" ^PSOORFI3
  K DIR S PSOSORT="ROUTE"
  S DIR("?")="^D RT^PSOORFI1",DIR("A")="Route",DIR(0)="SBM^W:WINDOW;M:MAIL;C:CLINIC;E:EXIT",DIR("B")="WINDOW"
  D ^DIR G:$D(DIRUT)!(Y="E") EX S PSOSORT=PSOSORT_"^"_Y,PSRT=Y
+ I $G(PSOAFYN)="Y" S PSOSORT="ROUTE^WINDOW",PSRT="WINDOW" ;vfah
  S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D
  .Q:$G(PAT($P(^PS(52.41,PSOD,0),"^",2)))=$P(^PS(52.41,PSOD,0),"^",2)  S PAT=$P(^PS(52.41,PSOD,0),"^",2)
@@ -44,7 +51,9 @@
  .D KQ F  S ORD=$O(^PS(52.41,"AC",PAT,"W",ORD)) Q:'ORD!($G(POERR("QFLG")))  D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE") LK1,ORD
  Q
-PAT W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT"
- S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE"
- D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT
+PAT I $G(PSOAFYN)'="Y" W ! K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
+ I $G(PSOAFYN)="Y" K MEDP,MEDA,POERR("DFLG"),DIR D KQ S PSOSORT="PATIENT" ;vfah
+ I $G(PSOAFYN)'="Y" S DIR("?")="^D PT^PSOORFI1",DIR("A")="All Patients or Single Patient",DIR(0)="SBM^A:ALL;S:SINGLE;E:EXIT",DIR("B")="SINGLE" ;vfah
+ I $G(PSOAFYN)'="Y" D ^DIR K DIR G:$D(DIRUT)!(Y="E") EX I Y="S" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
+ I $G(PSOAFYN)="Y" S PSOSORT=PSOSORT_"^"_"SINGLE" G SPAT ;vfah
  S PSOSORT=PSOSORT_"^ALL"
  S LG=0,PATA=0 F  S LG=$O(^PS(52.41,"AD",LG)) Q:'LG!($G(POERR("QFLG")))  F PSOD=0:0 S PSOD=$O(^PS(52.41,"AD",LG,PSOPINST,PSOD)) Q:'PSOD!($G(POERR("QFLG")))  D:$D(^PS(52.41,PSOD,0))
@@ -64,8 +73,11 @@
  G EX
 SPAT K MEDA,MEDP,PSOQFLG,PSORX("FN") D KQ,KV^PSOVER1
- S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT
- G:$D(DIRUT) EX D KV^PSOVER1
- S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))"
- D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y
+ ;PSOAFIN begin SPAT
+ I $G(PSOAFDON)=1 G EX ;vfah
+ I $G(PSOAFYN)'="Y" S DIR(0)="FO^2:30",DIR("A")="Select Patient",DIR("?")="^D HELP^PSOORFI2" D ^DIR I $E(X)="?" G SPAT ;vfah
+ I $G(PSOAFYN)'="Y" G:$D(DIRUT) EX D KV^PSOVER1 ;vfah
+ I $G(PSOAFYN)'="Y" S DIC(0)="EQM",DIC=2,DIC("S")="I $D(^PS(52.41,""AOR"",+Y,PSOPINST))" ;vfah
+ I $G(PSOAFYN)'="Y" D ^DIC K DIC G:"^"[X EX G:Y=-1 SPAT S (PSODFN,PAT)=+Y,PSOFINY=Y ;vfah
+ ;PSOAFIN end SPAT
  D LK I $G(POERR("QFLG")) G SPAT
  N SNGLPAT S SNGLPAT=1
@@ -73,7 +85,9 @@
  D PP,SDFN,POST^PSOORFI1 D:$G(PSOQFLG)  G:$G(PSOQFLG) EX I $G(PSOQUIT) S:$G(PSOQUIT) POERR("QFLG")=1 S X=PAT D ULP G SPAT
  .S X=PAT D ULP
- S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D
+ I PSOAFYN'="Y" S ORD=0 F  S ORD=$O(^PS(52.41,"P",PAT,ORD)) Q:'ORD!($G(POERR("QFLG")))  D  ;vhah
  .D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD
+ I PSOAFYN="Y" S ORD=0,ORD=$O(^PS(52.41,"B",+ORDERID,ORD)) D:$P(^PS(52.41,ORD,0),"^",3)'="DC"&($P(^(0),"^",3)'="DE")&($P(^(0),"^",3)'="HD") LK1,ORD ;vfah
  I $O(PSORX("PSOL",0))!($D(RXRS)) D LBL
+ I $G(PSOAFYN)="Y" S PSOAFDON=1 ;vfah
  S PSOFIN=1,X=PAT D ULP G SPAT
 ORD I $G(PSOBCK) N LST,ORN
@@ -91,22 +105,17 @@
  .K PSOREEDT S (PSOORRNW,PSOFDR)=1,PSORENW("OIRXN")=$P(OR0,"^",21),PSOOPT=3,(PSORENW("DFLG"),PSORENW("QFLG"))=0 D ^PSOORRNW,SQR^PSOORFI3
  I $P(OR0,"^",3)="RF",$D(^PSRX(+$P(OR0,"^",19),0)) D RF^PSOORFI2 G SUCC
- N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1,SQN^PSOORFI3
+ N PSODRUG,PSONEW S PSOFROM="PENDING" D:'$G(PSOTPBFG) DSPL^PSOTPCAN(ORD) D DSPL^PSOORFI1:'$D(ZTSK),SQN^PSOORFI3
 SUCC ;
- D UL1^PSOORFI3,FULL^VALM1
- D:$P($G(^PS(52.41,+$G(ORD),0)),"^",3)'="NW"&($P($G(^(0)),"^",3)'="RNW")&($P($G(^(0)),"^",3)'="HD")&($P($G(^(0)),"^",3)'="RF")
- .K PSOSD("PENDING",$S('$G(OID):$P(^PS(50.7,$P(OR0,"^",8),0),"^")_" "_$P(^PS(50.606,$P(^PS(50.7,$P(OR0,"^",8),0),"^",2),0),"^"),1:$P(^PSDRUG($P(OR0,"^",9),0),"^")))
- S:$G(POERR("DFLG")) POERR("QFLG")=1 K POERR("DFLG"),PSONEW,ACP,OR0,DRET,SIG,OID,OI,PSORX("SC"),PSORX("CLINIC"),PSODRUG
+ D SUCC^PSOORFI5
  Q
-LBL S PSOFROM="NEW" D ^PSORXL K PSORX("PSOL"),PPL,RXRS
- D:$D(BINGCRT)&($D(BINGRTE)&($D(DISGROUP))) ^PSOBING1 K BINGCRT,BINGRTE,PSONEW,BBFLG,BBRX
+ ;
+LBL ;
+ D LBL^PSOORFI5
  Q
+ ;
 CHK ;
- D:'$D(PSOPAR) ^PSOLSET I '$D(PSOPAR) W !,$C(7),"Outpatient Division MUST be selected!",! G EX
- D INST1^PSOORFI2
- S PSZCNT=0 F PSZZI=0:0 S PSZZI=$O(^PS(59,PSZZI)) Q:'PSZZI  S PSZCNT=PSZCNT+1
- S TC=0 F TO=0:0 S TO=$O(^PS(52.41,"AOR",TO)) Q:'TO  F TZ=0:0 S TZ=$O(^PS(52.41,"AOR",TO,TZ)) Q:'TZ  F PSTZ=0:0 S PSTZ=$O(^PS(52.41,"AOR",TO,TZ,PSTZ)) Q:'PSTZ  S TC=TC+1
- W !!?10,$C(7),"Orders to be completed"_$S(PSZCNT=1:": ",1:" for all divisions: ")_TC,! Q:'TC
- D SUMM^PSOORNE1 K PSZZI,PSZCNT,PSTZ
+ D CHK^PSOORFI5
  Q
+ ;
 PRI K DIR S PSOSORT="PRIORITY"
  S DIR("A")="Select Priority",DIR(0)="SBM^S:STAT;E:EMERGENCY;R:ROUTINE",DIR("B")="ROUTINE"
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE2.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOORNE2 ;BIR/SAB-display finished orders from backdoor ; 9/11/06 10:24am
- ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**11,21,23,27,32,37,46,84,103,117,131,146,156,210,148,222,238,264**;DEC 1997;Build 19
  ;^PSDRUG( -  221
  ;^YSCL(603.01 - 2697
@@ -31,5 +31,5 @@
  .S CLOZPAT=$S(CLOZPAT="M":2,CLOZPAT="B":1,1:0)
  I $D(^XUSEC("PSORPH",DUZ)) S RPH=1 D
- .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1:"DVE",ST=4:"DV",ST=3:"DU",ST=5:"ELTD",ST=11:"ETDPCL",ST=12&EXDT:"EDCL",ST=12&'EXDT:"ECL",ST>12&(ST'=16):"L",ST=16:"DL",1:"DHPEATCL")
+ .S PSOACT=$S('ST&($G(INDT)]"")&(DT>$G(INDT)):"DHPLATC",ST=1:"DVE",ST=4:"DV",ST=3:"DU",ST=5:"ELTD",ST=11:"TDPCL",ST=12&EXDT:"DCL",ST=12&'EXDT:"CL",ST>12&(ST'=16):"L",ST=16:"DL",1:"DHPEATCL")
  .D GET^PSOORNE5 S PSOACT=PSOACT_$S(ACTREN:"N",1:""),PSOACT=PSOACT_$S(ACTREF:"R",1:"")
  .I ST=5 S SURX=$O(^PS(52.5,"B",RXN,0)) I SURX,$P($G(^PS(52.5,SURX,0)),"^",7)="L" S PSOACT="TL" K SURX Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE4.m	(revision 636)
@@ -1,4 +1,6 @@
-PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;07/29/96
- ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131**;DEC 1997
+PSOORNE4 ;BIR/SAB-display renew RXs from backdoor ;1/27/07  13:28
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,36,46,75,96,103,99,117,131,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; GPL Copyright (C) 2007 WorldVistA
  ;^SC DBIA-10040;^PS(50.7-2223;^PS(50.606-2174;^PS(50.607-2221;^PS(51.2-2226;^PSDRUG-221;^PS(55-2228
 EN(PSONEW) N FLD,LST,VALMCNT
@@ -7,6 +9,7 @@
  .K PSONEW("DOSE"),PSONEW("UNITS"),PSONEW("DOSE ORDERED"),PSONEW("ROUTE")
  .K PSONEW("SCHEDULE"),PSONEW("DURATION"),PSONEW("CONJUNCTION"),PSONEW("NOUN"),PSONEW("VERB"),PSOPRC,PSONEW("ODOSE")
-RDD D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q
- G:'$G(PSOQUIT) RDD
+RDD I $G(PSOAFYN)'="Y" D DSPL,^PSOLMRN D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q  ;vfah
+ I $G(PSOAFYN)="Y" D ACP D:$G(PKI1)=2 DCP^PSOPKIV1 I $G(PSORX("FN")) S VALMBCK="Q" K PSOREEDT Q  ;vfah D ACP from D ACP^PSOLMRN above
+ I $G(PSOAFYN)'="Y" G:'$G(PSOQUIT) RDD ;vfah
  Q
 EDT D KV^PSOVER1 S DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:"_$S($G(PSOREEDT):10,1:8)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNE5.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/10/07 8:29am
- ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268,206**;DEC 1997;Build 39
+PSOORNE5 ;BIR/SAB - display orders from backdoor con't ;5/23/05 1:46pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,46,78,99,117,131,146,171,180,210,222,268**;DEC 1997;Build 9
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references L and UL^PSSLOCK supported by DBIA 2789
@@ -51,5 +51,5 @@
  F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSODIR("CS"),"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSODIR("CS"),"^",2)=1
  I $P($G(PSODIR("CS")),"^",2)=1 S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
- I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
+ I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=0 Q
  I $D(CLOZPAT) S (PSONEW("# OF REFILLS"),PSONEW("N# REF"))=$S($G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=14):1,$G(CLOZPAT)=2&(PSONEW("DAYS SUPPLY")=7):3,$G(CLOZPAT)=1&(PSONEW("DAYS SUPPLY")=7):1,1:0) Q
  I PSODIR("CS") D
@@ -72,5 +72,5 @@
  S:PSORFRM<0 PSORFRM=0 S:PSORFRM=0 ACTREF=0
  I $G(RXFL(RXN))]"",'$P(PSOPAR,"^",6) S ACTREF=0
- I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREF=0
+ I $P(PSODRUG0,"^",3)["A"&($P(PSODRUG0,"^",3)'["B")!($P(PSODRUG0,"^",3)["F") S ACTREF=0
  ;renews
  I $P(PSOPAR,"^",4)=0 S ACTREN=0 Q
@@ -78,5 +78,6 @@
  I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) S ACTREN=0,VALMSG="This Drug has been Inactivated."
  I '$P($G(^PSDRUG(PSODRG,2)),"^"),'$P($G(^PSRX(RXN,"OR1")),"^") S ACTREN=0,VALMSG="Drug must be Matched to an Orderable Item!"
- I ($P(PSODRUG0,"^",3)["W")!($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2) S ACTREN=0
+ I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" S ACTREN=0
+ I $P(PSODRUG0,"^",3)["W" S ACTREN=0
  I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) S ACTREN=0
  S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 S ACTREN=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNEW.m	(revision 636)
@@ -1,11 +1,17 @@
-PSOORNEW ;BIR/SAB - display orders from oerr ;4/25/07 8:50am
- ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,206**;DEC 1997;Build 39
+PSOORNEW ;BIR/SAB - display orders from oerr ;1/27/07  13:29
+ ;;7.0;OUTPATIENT PHARMACY;**11,23,27,32,55,46,71,90,94,106,131,133,143,237,222,258,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
  ;^PS(50.7 -2223
  ;^PSDRUG -221
  ;^PS(50.606 -2174
  ;^PS(55 -2228
- ;
  ;PSO*237 quit Finish if Today > Issue date + 365
- ;
 DSPL I $G(PSODSPL) S VALMBCK="Q" K PSODSPL,PSOANSQD Q
  Q:'$D(PSOLMC)  K ^TMP("PSOPO",$J) S PSOLMC=PSOLMC+1
@@ -15,5 +21,5 @@
  .S (OI,PSODRUG("OI"))=$P(OR0,"^",8),PSODRUG("OIN")=$P(^PS(50.7,$P(OR0,"^",8),0),"^"),OID=$P(OR0,"^",9)
  .I $P($G(OR0),"^",9) S POERR=1,DREN=$P(OR0,"^",9) D DRG^PSOORDRG K POERR
- I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) S PSONEW("# OF REFILLS")=0
+ I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A",$G(PSODRUG("DEA"))'["B"!($G(PSODRUG("DEA"))["F") S PSONEW("# OF REFILLS")=0
  I $D(CLOZPAT) S PSONEW("# OF REFILLS")=$S($D(PSONEW("# OF REFILLS")):PSONEW("# OF REFILLS"),$G(CLOZPAT)=2&($P(OR0,"^",11)>2):3,$G(CLOZPAT)&($P(OR0,"^",11)>1):1,1:0)
  S IEN=0 D OBX^PSOORFI1,DIN^PSONFI(PSODRUG("OI"),$S($G(PSODRUG("IEN")):PSODRUG("IEN"),1:""))
@@ -66,5 +72,6 @@
  S:PSOLMC>1 VALMBCK="R"
  Q
-ORCHK D PROVCOM^PSOORFI4,ORCHK^PSOORFI4
+ORCHK D PROVCOM^PSOORFI4
+ I $G(PSOAFYN)'="Y" D ORCHK^PSOORFI4
  Q
 EDT D KV S DIR("A",1)="* Indicates which fields will create an new Order",DIR("A")="Select Field to Edit by number",DIR(0)="LO^1:15" D ^DIR Q:$D(DTOUT)!($D(DUOUT))
@@ -85,16 +92,21 @@
  D RXNCHK^PSOORNE1 I $G(PSONEW("QFLG")) S PSONEW("DFLG")=1 Q
  I DT>$$FMADD^XLFDT($P(OR0,"^",6),365) D EXPR^PSONEW2 G DSPL
- D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
+ I $G(PSOAFYN)'="Y" D STOP^PSONEW2,DISPLAY^PSONEW2,^PSONEWF
+ I $G(PSOAFYN)="Y" D STOP^PSONEW2
  I $G(PSOCPZ("DFLG")) W !!,"No action taken!",! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR,KV K PSOCPZ("DFLG"),DRET,PSOANSQD S VALMBCK="Q" Q
- K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q
+ I $G(PSOAFYN)'="Y" K PSOCPZ("DFLG") D KV S DIR(0)="Y",DIR("A")="Are you sure you want to Accept this Order",DIR("B")="NO" D ^DIR I $D(DIRUT) D KV K DRET,PSOANSQ,PSOANSQD S VALMBCK="Q" Q
+ I $G(PSOAFYN)="Y" S Y="1"
  D KV I 'Y K PSOANSQ G DSPL
  I $G(PSONEW("MAIL/WINDOW"))["W" D:$P($G(PSOPAR),"^",12)  S BINGCRT="Y",BINGRTE="W",PSORX("MAIL/WINDOW")="WINDOW" K RTN
- .W ! K DIR,DIRUT S DIR(0)="52,35O"
- .S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q
- .S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
+ .I $G(PSOAFYN)'="Y" W ! K DIR,DIRUT S DIR(0)="52,35O"
+ .I $G(PSOAFYN)'="Y" S:$G(PSORX("METHOD OF PICK-UP"))]"" DIR("B")=PSORX("METHOD OF PICK-UP") D ^DIR I $D(DIRUT) K DIR,DIRUT Q
+ .I $G(PSOAFYN)'="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))=Y K X,Y
+ .I $G(PSOAFYN)="Y" S (PSONEW("METHOD OF PICK-UP"),PSORX("METHOD OF PICK-UP"))="AutoFinished for Rx Printing"
  S PSONEW("POE")=1 D EN^PSON52(.PSONEW) G:$G(PSONEW("DFLG")) ABORT D DCORD^PSONEW2
  D NPSOSD^PSOUTIL(.PSONEW),FULL^VALM1 K PSORX("MAIL/WINDOW")
  D EOJ^PSONEW
-ABORT S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV
+ABORT ;
+ I $G(PSOAFYN)'="Y" S VALMBCK="Q",DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR,CLEAN^PSOVER1,KV ;vfah
+ I $G(PSOAFYN)="Y" D CLEAN^PSOVER1,KV ;vfah
  Q
 KV K DIRUT,DUOUT,DTOUT,DIR
@@ -136,5 +148,4 @@
  ;
 DRGMSG ;
- F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
- .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)
- K SG Q
+ D DRGMSG^PSOORNW2 Q  ;vfam
+ ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;5/10/07 8:30am
- ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268,206**;DEC 1997;Build 39
+PSOORNW1 ;ISC BHAM/SAB - continuation of finish of new order ;07/19/96 12:58 PM
+ ;;7.0;OUTPATIENT PHARMACY;**23,46,78,117,131,133,172,148,222,268**;DEC 1997;Build 9
  ;Reference ^YSCL(603.01 supported by DBIA 2697
  ;Reference ^PS(55 supported by DBIA 2228
@@ -67,5 +67,5 @@
  E  D
  .S PSOX=$S($P($G(OR0),"^",11)'>PTRF&($P($G(OR0),"^",11)'>11):11,1:PTRF)
- I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q
+ I '$D(CLOZPAT) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOX=0,PSONEW("# OF REFILLS")=0 K PSDY,PSDY1,PTRF Q
  I $D(CLOZPAT) S (PSOX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(CLOZPAT=2&($G(PSONEW("# OF REFILLS"))>2):3,CLOZPAT&($G(PSONEW("# OF REFILLS"))>1):1,1:0),PSONEW("DAYS SUPPLY")=7,ORCHK=1 K PSDY,PSDY1,PTRF Q
  S PSONEW("# OF REFILLS")=$S($G(PSONEW("# OF REFILLS"))'="":$G(PSONEW("# OF REFILLS")),1:PSOX) K PSDY,PSDY1,PTRF
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORNW2.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ; 6/28/07 11:36am
- ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,269,206**;DEC 1997;Build 39
+PSOORNW2 ;ISC-BHAM/SAB - edit orders from oerr ; 12/10/06 9:55pm
+ ;;7.0;OUTPATIENT PHARMACY;**10,23,37,46,117,131,133,148,222,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Reference to ^YSCL(603.01 supported by DBIA 2697
  ;Reference to ^PS(55 supported by DBIA 2228
@@ -11,7 +27,5 @@
  S DIC("B")=$S($G(PSODRUG("OIN"))]"":PSODRUG("OIN"),1:""),DIC="^PS(50.7,",DIC(0)="AEMQZ"
  S DIC("S")="I '$P(^PS(50.7,+Y,0),""^"",4)!($P(^(0),""^"",4)'<DT) N PSOF,PSOL S (PSOF,PSOL)=0 F  S PSOL=$O(^PSDRUG(""ASP"",+Y,PSOL)) Q:PSOF!'PSOL  "
- S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1"
- ;BHW;PSO*7*269;Modify ^DIC call to call MIX^DIC to use only the B and C Cross-References.
- S D="B^C" D MIX^DIC1 K DIC,D I X["^"!($D(DTOUT)) S OUT=1 Q
+ S DIC("S")=DIC("S")_"I $P($G(^PSDRUG(PSOL,2)),U,3)[""O"",'$G(^(""I""))!($G(^(""I""))'<DT) S PSOF=1" D ^DIC K DIC I X["^"!($D(DTOUT)) S OUT=1 Q
  S PSOY=Y
  I +Y'=OI D  I 'Y!($D(DIRUT)) D KV,MP1^PSOOREDX K DIC,Y,PSOY S OUT=1 Q
@@ -37,6 +51,6 @@
  .S PSONEW("# OF REFILLS")=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
  I $G(PSOMAX) S PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
- I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D
- .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
+ I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D
+ .S PSONEW("# OF REFILLS")=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
  Q
  ;
@@ -62,9 +76,9 @@
  .S:'$G(PSONEW("# OF REFILLS")) PSONEW("# OF REFILLS")=$S(+$P(OR0,"^",11)>PSOMAX:PSOMAX,1:+$P(OR0,"^",11))
  .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=$S(PSONEW("# OF REFILLS")>PSOMAX:PSOMAX,1:PSONEW("# OF REFILLS"))
- .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q
- ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
+ .I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
+ ..S (PSOMAX,PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
  .I $D(PSODRUG("DEA")) F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S PSOMAX=5
- I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F")!($G(PSODRUG("DEA"))[1)!($G(PSODRUG("DEA"))[2) D  Q
- .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["A":"this narcotic drug.",1:"this drug.")
+ I '$D(CLOZPAT) I $G(PSODRUG("DEA"))["A"&($G(PSODRUG("DEA"))'["B")!($G(PSODRUG("DEA"))["F") D  Q
+ .S (PSONEW("N# REF"),PSONEW("# OF REFILLS"))=0,VALMSG="No refills allowed on "_$S(PSODRUG("DEA")["F":"this drug.",1:"Narcotics ...")
  S (PSONEW("N# REF"),PSOMAX,PSONEW("# OF REFILLS"))=+$P(OR0,"^",11)
 ASK S PSONEW("FLD")=9 D REFILL^PSODIR1(.PSONEW) ; Get # of refills
@@ -88,4 +102,10 @@
 14 S PSONEW("FLD")=13 D RMK^PSODIR2(.PSONEW) ; Get Remarks
  Q
+ ;
+DRGMSG ;From PSOORNEW
+ F SG=1:1:$L($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)) S:$L(^TMP("PSOPO",$J,IEN,0)_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOPO",$J,IEN,0)," ",20)=" " D
+ .S:$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)'="" ^TMP("PSOPO",$J,IEN,0)=$G(^TMP("PSOPO",$J,IEN,0))_" "_$P($P(^PSDRUG(PSODRUG("IEN"),0),"^",10)," ",SG)
+ K SG Q
+ ;
 DREN ;
  S (PSDC,PSI)=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRNW.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRNW.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORRNW.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOORRNW ;BIR/SAB-finish OP renew orders from OE/RR ;4/25/07 8:46am
- ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,206**;DEC 1997;Build 39
+PSOORRNW ;BIR/SAB-finish OP renew orders from OE/RR ; 11/3/06 10:02pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,51,46,71,94,130,131,146,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^PS(50.607 supported by DBIA 2221
@@ -6,10 +22,12 @@
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
  S PSORENXX=$P($G(OR0),"^",21),PSOFROM="NEW" K PRC,PHI
- I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) I '$G(PSOMSG) D  K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q
+ I $G(PSOAFYN)'="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) I '$G(PSOMSG) D  K DIR,PSOMSG W ! S DIR("A")="Press Return to continue",DIR(0)="E" D ^DIR K DIR W ! Q  ;vfah
  .I $P($G(PSOMSG),"^",2)'="" W $C(7),!!,$P(PSOMSG,"^",2) Q
  .W $C(7),!!,"Another person is editing Rx "_$P($G(^PSRX(PSORENXX,0)),"^")
- K PSOMSG N OI,VALMCNT K POERR("DFLG") D FULL^VALM1 S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT
+ I $G(PSOAFYN)="Y" I $G(PSORENXX) D PSOL^PSSLOCK(PSORENXX) ;vfah
+ I $G(PSOAFYN)'="Y" K PSOMSG N OI,VALMCNT K POERR("DFLG") D FULL^VALM1 S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT ;vfah
+ I $G(PSOAFYN)="Y" K PSOMSG N OI,VALMCNT K POERR("DFLG") S (PSORX("DFLG"),PSORENW("DFLG"))=0,(PSORNW("FILL DATE"),PSORENW("FILL DATE"))=DT ;vfah
  S Y=DT X ^DD("DD") S PSORX("FILL DATE")=Y K Y
- W !!,"Now Renewing Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^")_"   Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^"),! H 2
+ I $G(PSOAFYN)'="Y" W !!,"Now Renewing Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^")_"   Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^"),! H 2 ;vfah
  I $P($G(^PSRX($P(OR0,"^",21),"OR1")),"^",4) D  D PROCESSX^PSORENW0 D UL Q
  .W !!,"Cannot Renew Rx # "_$P(^PSRX($P(OR0,"^",21),0),"^"),!," Drug: "_$P($G(^PSDRUG($P(^PSRX($P(OR0,"^",21),0),"^",6),0)),"^")_"."
@@ -52,6 +70,5 @@
  .S PSOCS=0 K DIR,DIC,PSOX
  .F DEA=1:1 Q:$E(PSODRUG("DEA"),DEA)=""  I $E(+PSODRUG("DEA"),DEA)>1,$E(+PSODRUG("DEA"),DEA)<6 S $P(PSOCS,"^")=1 S:$E(+PSODRUG("DEA"),DEA)=2 $P(PSOCS,"^",2)=1
- .;PSO*7*206
- .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F")!(PSODRUG("DEA")[1)!(PSODRUG("DEA")[2) S PSOMAX=0
+ .S PSOMAX=$S(PSOCS:5,1:11) I PSODRUG("DEA")["A"&(PSODRUG("DEA")'["B")!(PSODRUG("DEA")["F") S PSOMAX=0
  E  S PSOMAX=$P(OR0,"^",11)
  S RXPT=+$P(PSORENW("RX0"),"^",3) I $G(^PS(53,RXPT,0))]"" D
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUT1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ; 6/28/07 7:36am
- ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233,274**;DEC 1997;Build 8
+PSOORUT1 ;BIR/SAB - Utility routine for oerr interface ;02/22/95
+ ;;7.0;OUTPATIENT PHARMACY;**1,14,30,46,132,148,233**;DEC 1997;Build 8
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^PSXOPUTL supported by DBIA 2203
@@ -29,5 +29,5 @@
  .I $$SUBMIT^PSOBPSUT(DA) D ECMESND^PSOBPSU1(DA,,$$RXFLDT^PSOBPSUT(DA),$S('$O(^PSRX(DA,1,0)):"OF",1:"RF"))
  G EXIT^PSOORUTL
-ACT1 S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
+ACT1 I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOORUTL.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOORUTL ;ISC BHAM/SAB  - updates order status from oerr ; 6/28/07 7:36am
- ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249,274**;DEC 1997;Build 8
+PSOORUTL ;ISC BHAM/SAB  - updates order status from oerr ;02/22/95
+ ;;7.0;OUTPATIENT PHARMACY;**14,46,146,132,118,199,223,148,249**;DEC 1997;Build 9
  ;External reference to EN^ORERR - 2187
  ;External reference to ^PS(55 - 2228
@@ -104,5 +104,4 @@
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
- S RXF=$S(RXF>5:RXF+1,1:RXF)
  S ^PSRX(DA,"A",IR,0)=NOW_"^"_$S(ACT:"U",1:"H")_"^"_POERR("USER")_"^"_RXF_"^"_"RX "_$S('ACT:"placed in a",1:"removed from")_" HOLD status "_$S(+$G(PSUS):"and removed from SUSPENSE ",1:"")_"("_$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)_") by OERR."
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP0.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOPMP0 ;BIRM/MFR - Patient Medication Profile - Listmanager ;10/28/06
- ;;7.0;OUTPATIENT PHARMACY;**260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84
  ;Reference to EN1^GMRADPT supported by IA #10099
  ;Reference to EN6^GMRVUTL supported by IA #1120
@@ -14,6 +14,4 @@
  ; - Patient selection
  W !! S DIC=2,DIC(0)="QEAM" D ^DIC G EXIT:Y<0  S DFN=+Y
- ;
- S PSODFN=DFN D CHKADDR^PSOBAI(DFN,1,1)  ;bad address flag/update
  ;
  D LST(PSOSITE,DFN)
@@ -102,5 +100,5 @@
  ;
 SETSORT(FIELD) ; - Sets the data sorted by the FIELD specified
- N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI,PSOBADR
+ N SEQ,RX,RXNUM,DRUG,DRNAME,QTY,STATUS,STS,ISSDT,DOCDAT,LSTFD,REFREM,DAYSUP,SIG,Z,ORD,GRPCNT,GROUP,RFRX,OI
  ;
  K ^TMP("PSOPMPSR",$J)
@@ -120,9 +118,6 @@
  . S REFREM=$$REFREM^PSOPMP1(RX)
  . S DAYSUP=$$GET1^DIQ(52,RX,8)
- . S PSOBADR=$O(^PSRX(RX,"L",9999),-1)
- . I PSOBADR'="" S PSOBADR=$G(^PSRX(RX,"L",PSOBADR,0)) I PSOBADR["(BAD ADDRESS)" S PSOBADR="B"
- . I PSOBADR'="B" S PSOBADR=""
  . S Z="",$P(Z,"^")=RX,$P(Z,"^",2)=RXNUM_$$COPAY^PSOPMP1(RX)_$$ECME^PSOBPSUT(RX),$P(Z,"^",3)=$E(DRNAME,1,30)
- . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX)_PSOBADR,$P(Z,"^",6)=$P(ISSDT,"^",2)
+ . S $P(Z,"^",4)=QTY,$P(Z,"^",5)=$P(STATUS,"^",3)_$$CMOP^PSOPMP1(DRUG,RX),$P(Z,"^",6)=$P(ISSDT,"^",2)
  . S $P(Z,"^",7)=$P(LSTFD,"^",2),$P(Z,"^",8)=REFREM,$P(Z,"^",9)=DAYSUP
  . S SORT=$S(FIELD="RX":RXNUM_" ",FIELD="DR":DRNAME_RXNUM,FIELD="ID":+ISSDT_RXNUM_" ",FIELD="LF":+LSTFD_RXNUM_" ")
@@ -231,7 +226,7 @@
  ;
  ; - Regular prescription
- I TYPE="RX" D  S VALMBCK="R" D REF
+ I TYPE="RX" D
  . N PSOVDA,PSOSAVE,DA,PS
- . S (PSOVDA,DA)=ORD,PS="REJECTMP"
+ . S (PSOVDA,DA)=ORD,PS="REJECT"
  . N LINE,TITLE,PSODFN D DP^PSORXVW
  ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOPMP1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOPMP1 ;BIRM/MFR - Patient Medication Profile - Listmanager ;04/28/05
- ;;7.0;OUTPATIENT PHARMACY;**260,285,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**260**;DEC 1997;Build 84
  ;Reference to ^PSDRUG("AQ" supported by IA 3165
  ;Reference to EN1^GMRADPT supported by IA 10099
@@ -17,5 +17,5 @@
  . . S LBL=GRPLN(LN),POS=41-($L(LBL)\2)
  . . D CNTRL^VALM10(LN,1,POS-1,IOUON_IOINHI,IOINORM)
- . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IORVOFF_IOINORM)
+ . . D CNTRL^VALM10(LN,POS,$L(LBL),IORVON_IOINHI,IOINORM)
  . . D CNTRL^VALM10(LN,POS+$L(LBL),81-POS-$L(LBL),IOUON_IOINHI,IOINORM)
  Q
@@ -73,5 +73,5 @@
 FILTER(RX) ; - Filter Rx's that should not be displayed
  I $$GET1^DIQ(52,RX,26,"I")<PSOEXPDC Q 1
- I $$GET1^DIQ(52,RX,26.1,"I"),$$GET1^DIQ(52,RX,26.1,"I")<PSOEXPDC,$$GET1^DIQ(52,RX,100,"I")>11,$$GET1^DIQ(52,RX,100,"I")'=16 Q 1
+ I $$GET1^DIQ(52,RX,26.1,"I")<PSOEXPDC,$$GET1^DIQ(52,RX,100,"I")>11,$$GET1^DIQ(52,RX,100,"I")'=16 Q 1
  I $$GET1^DIQ(52,RX,100,"I")=""!($$GET1^DIQ(52,RX,100,"I")=13) Q 1
  I $$GET1^DIQ(52,RX,.01)="" Q 1
@@ -152,5 +152,5 @@
  I GMRAL S ALLERGY="<A>"
  E  D ALLERGY^PSOORUT2 I PSONOAL'="" S ALLERGY="<NO ALLERGY ASSESSMENT>"
- S ALLERGY=IORVON_ALLERGY_IORVOFF_IOINORM
+ S ALLERGY=IORVON_ALLERGY_IOINORM
  I '$G(POS) S POS=80-$L(ALLERGY)
  S LINE=$$SETSTR^VALM1(ALLERGY,LINE,POS,80)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOR52.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOR52 ;IHS/DSD/JCM - Files refill entries in prescription file ;03/10/93
- ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**10,22,27,181,148,201,260**;DEC 1997;Build 84
  ;Reference to ^PSDRUG supported by DBIA 221
  ;Reference to PSOUL^PSSLOCK supported by DBIA 2789
@@ -84,5 +84,5 @@
  . S ACTION="" D ECMESND^PSOBPSU1(PSOERX,PSOERF,PSOX("FILL DATE"),"RF")
  . I $$FIND^PSOREJUT(PSOERX,PSOERF) D
- . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(PSOERX,PSOERF,"79,88","OF","IOQ","I")
  . I $$STATUS^PSOBPSUT(PSOERX,PSOERF)="E PAYABLE" D
  . . D SAVNDC^PSSNDCUT(+$$GET1^DIQ(52,PSOERX,6,"I"),$G(PSOSITE),$$GETNDC^PSONDCUT(PSOERX,PSOERF))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREF.m	(revision 636)
@@ -1,4 +1,17 @@
-PSOREF ;BIR/SAB-refill data entry ;4/25/07 8:45am
- ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,206**;DEC 1997;Build 39
+PSOREF ;BIR/SAB-refill data entry ;1/27/07  13:31
+ ;;7.0;OUTPATIENT PHARMACY;**1,23,27,36,46,78,130,131,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
@@ -9,4 +22,9 @@
  Q
 OERR ;single refil
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Refill option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
  I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2),,.VALMSG,.VALMBCK) Q
  I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
@@ -29,4 +47,8 @@
  K DIR,DIRUT,DTOUT,PSOOELSE,DTOUT I +Y S (ASK,SPEED,PSOOELSE)=1 D FULL^VALM1 S LST=Y D  G:$G(PSOREF("DFLG"))!($G(PSOREF("QFLG"))) SPEEDX
  .F ORD=1:1:$L(LST,",") Q:$P(LST,",",ORD)']""!($G(PSOREF("QFLG")))  S ORN=$P(LST,",",ORD) D:+PSOLST(ORN)=52
+ ..S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ ..D ^DIC K DIC ;vfah
+ ..S PSOZAF=+Y ;vfah
+ ..I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and can not be refilled" K PSOZAF D PAUSE^VALM1 Q  ;vfah
  ..I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Reject!" K DIR D PAUSE^VALM1 Q
  ..D PSOL^PSSLOCK($P(PSOLST(ORN),"^",2)) I '$G(PSOMSG) W $C(7),!!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing Rx "_$P(^PSRX($P(PSOLST(ORN),"^",2),0),"^")),! D PAUSE^VALM1 K PSOMSG Q
@@ -85,5 +107,5 @@
  I '$P($G(^PSRX(RXN,"OR1")),"^"),$P($G(^PSDRUG(PSODRG,2)),"^") S $P(^PSRX(RXN,"OR1"),"^")=$P(^PSDRUG(PSODRG,2),"^")
  S CLOZPAT=$S($P($G(^PSDRUG(PSODRG,"CLOZ1")),"^")="PSOCLO1":1,1:0)
- I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F")!(PSODEA[1)!(PSODEA[2) Q "0^"_$S(PSODEA["A":"Narcotic Drug. ",1:"")_"Order Non-Refillable."
+ I 'CLOZPAT I PSODEA["A"&(PSODEA'["B")!(PSODEA["F") Q "0^"_$S(PSODEA["F":"",1:"Narcotic Drug. ")_"Order Non-Refillable."
  K CLOZPAT I DT>$P($G(^PSRX(RXN,2)),"^",6) Q "0^Non-Refillable.  Prescription has Expired."
  I $P(^PSRX(RXN,3),"^",2)>$P(^PSRX(RXN,2),"^",6) Q "0^Next Refill Date Past Expiration Date.  New Order Required."
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOREJP1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOREJP1 ;BIRM/MFR - Third Party Reject Display Screen ;04/29/05
- ;;7.0;OUTPATIENT PHARMACY;**148,247,260,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**148,247,260**;DEC 1997;Build 84
  ;Reference to File 9002313.93 - BPS NCPDP REJECT CODES supported by IA 4720
  ;Reference to ^PS(59.7 supported by IA 694
@@ -26,9 +26,9 @@
  K ^TMP("PSOREJP1",$J) S VALMCNT=0,LINE=0
  D GET^PSOREJU2(RX,FILL,.DATA,REJ,1)
- D REJ           ; Display REJECT Info
- D OTH           ; Display Other Rejects Info
- D COM^PSOREJP3  ; Display Comment
- D INS           ; Display Insurance Info
- D CLS           ; Display Resolution Info
+ D REJ                   ; Display the REJECT Information
+ D OTH                   ; Display the Other Rejects Information
+ D COM^PSOREJP3          ; Display the Comment
+ D INS                   ; Display the Insurance Information
+ D CLS                   ; Display the Resolution Information
  S VALMCNT=LINE
  Q
@@ -251,8 +251,5 @@
  ;
 OUT(RX) ; - Supported call by outside PROTOCOLs to act on specific REJECTs
- N I,RFL,DATA,REJ,PSOBACK,VALMCNT,RXN
- I '$D(^XUSEC("PSORPH",DUZ)) S VALMSG="PSORPH key required to use the REJ action.",VALMBCK="R" Q
- I $G(PS)="REJECT" D  Q
- . S VALMSG="REJ action is not available at this point.",VALMBCK="R"
+ N I,RFL,DATA,REJ,PSOBACK,VALMCNT
  S PSOBACK=1
  S (RFL,I)=0 F I=1:1 Q:'$D(^PSRX(RX,1,I))  S RFL=I
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORELD1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORELD1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORELD1.m	(revision 636)
@@ -1,4 +1,22 @@
-PSORELD1 ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME CONT. ;03/22/04
- ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997
+PSORELD1 ;BIR/PWC-HL7 V.2.4 EXTERNAL INTERFACE RELEASE DATE/TIME CONT. ;5:23 AM  31 Jan 2008
+ ;;7.0;OUTPATIENT PHARMACY;**156**;DEC 1997;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
  ;HLFNC supp. by DBIA 10106
  ;PSNAPIS supp. by DBIA 2531
@@ -25,6 +43,8 @@
  D PID(.PSI),PV1(.PSI),PV2(.PSI),ORC(.PSI),RXE(.PSI),RXD(.PSI)
  ; clean up data set by GETDATA
- K BINGO,RELDT,SITE,SITADD,SITPHN,PSOXN,PSOXN2,PSND1,PSND2,PSND3,PRODUCT,PSOPROD,VANAME,UNIT,PSDOSE,PODOSENM,POIPTR,NRFL,DISPDT,COPAY,ERR,PSONDC,NFDL,NFLD,PSZIP,PSOHZIP,TRADENM,X,Y,UU
- Q
+ K BINGO,RELDT,SITE,SITADD,SITPHN,PSOXN,PSOXN2,PSND1,PSND2,PSND3,PRODUCT,PSOPROD,VANAME
+ K UNIT,PSDOSE,PODOSENM,POIPTR,NRFL,DISPDT,COPAY,ERR,PSONDC,NFDL,NFLD,PSZIP,PSOHZIP,TRADENM,X,Y,UU
+ QUIT
+ ;  ========
 GETDATA ; this is the place to set all data needed for several segments
  I $G(FP)="F"&('$G(FPN)) D    ;original
@@ -32,10 +52,14 @@
  . S PVDR=$P(^PSRX(IRXN,0),"^",4),QTY=$P(^(0),"^",7),DASPLY=$P(^(0),"^",8),MW=$P(^(0),"^",11),EBY=$P(^(0),"^",16)
  I $G(FP)="F"&($G(FPN)) D    ;refill
- . S FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",19),EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:$P(^PSRX(IRXN,2),"^",6))
+ . S FDT=$P(^PSRX(IRXN,1,FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",19)
+ . S EXDT=$S($P(^(0),"^",15):$P(^(0),"^",15),1:$P(^PSRX(IRXN,2),"^",6))
  . S VPHARMID=$S($P(^PSRX(IRXN,1,FPN,0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10))
- . S EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17),PSONDC=$S($P($G(^PSRX(IRXN,1,FPN,1)),"^",3):$P(^(1),"^",3),1:$P(^PSRX(IRXN,2),"^",7))
+ . S EBY=$S($P(^PSRX(IRXN,1,FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),PVDR=$P(^(0),"^",17)
+ . S PSONDC=$S($P($G(^PSRX(IRXN,1,FPN,1)),"^",3):$P(^(1),"^",3),1:$P(^PSRX(IRXN,2),"^",7))
  I $G(FP)="P" D  ;partial
- . S FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",13),PVDR=$P(^(0),"^",17),EXDT=$P(^PSRX(IRXN,2),"^",6)
- . S EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7)),VPHARMID=$S($P(^(0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10)),PVDR=$P(^PSRX(IRXN,"P",FPN,0),"^",17)
+ . S FDT=$P(^PSRX(IRXN,"P",FPN,0),"^"),MW=$P(^(0),"^",2),QTY=$P(^(0),"^",4),DASPLY=$P(^(0),"^",10),DISPDT=$P(^(0),"^",13)
+ . S PVDR=$P(^(0),"^",17),EXDT=$P(^PSRX(IRXN,2),"^",6)
+ . S EBY=$S($P(^PSRX(IRXN,"P",FPN,0),"^",5):$P(^(0),"^",5),1:$P(^(0),"^",7))
+ . S VPHARMID=$S($P(^(0),"^",5)'="":$P(^(0),"^",5),1:$P(^PSRX(IRXN,2),"^",10)),PVDR=$P(^PSRX(IRXN,"P",FPN,0),"^",17)
  . S PSONDC=$S($P(^PSRX(IRXN,"P",FPN,0),"^",12):$P(^(0),"^",12),1:$P(^PSRX(IRXN,2),"^",7))
  S EFDT=$P(^PSRX(IRXN,2),"^",2) S:$G(EFDT) EFDT=$$HLDATE^HLFNC(EFDT,"DT")
@@ -43,9 +67,9 @@
  S DEAID=$$GET1^DIQ(200,PVDR_",",53.2)
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=VPHARMID D ^DIC
- S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S VPHARM=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=EBY D ^DIC
- S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S EBY1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=PVDR D ^DIC
- S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S PVDR1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  S PRIORDT=$P(^PSRX(IRXN,3),"^",4),PRIORDT=$$HLDATE^HLFNC(PRIORDT,"DT")
  S FDT=$$HLDATE^HLFNC(FDT,"DT")
@@ -55,5 +79,5 @@
  S FIN=$P(^PSRX(IRXN,"OR1"),"^",5)
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=FIN D ^DIC
- S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S FIN1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  S SITE=$S($D(^PS(59,PSOSITE,0)):^(0),1:"")
  S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
@@ -61,5 +85,5 @@
  S CSINER=$P(^PSRX(IRXN,3),"^",3)
  K DIC,X,Y S DIC="^VA(200,",DIC(0)="N,Z",X=CSINER D ^DIC
- S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)):1,"""""") K DIC,X,Y
+ S CSINER1=$S(+Y:$$HLNAME^HLFNC($P(Y,"^",2)),1:"""""") K DIC,X,Y
  D 6^VADPT
  I MW="W" S MP=$S($P($G(^PSRX(IRXN,"MP")),"^"):$P(^("MP"),"^"),1:"""""")
@@ -87,7 +111,9 @@
  S NFLD=0,UU="" F  S UU=$O(^PSRX(IRXN,1,UU)) Q:UU=""  S:$D(^PSRX(IRXN,1,UU,0)) NFLD=NFLD+1
  S NRFL=$P(^PSRX(IRXN,0),"^",9),RFRM=(NRFL-NFLD)
- Q
+ QUIT
+ ;  =========
 PID(PSI) ;patient ID segment
- Q:'$D(DFN)!$D(PAS)
+ QUIT:'$D(DFN)!$D(PAS)
+ ;
  S HLFS=HL1("FS"),HLECH=HL1("ECH"),HLQ=HL1("Q"),HLVER=HL1("VER")
  K PSPID,PSPID1
@@ -127,5 +153,6 @@
  S PAS=1
  K PSPID,PSPID1,PRSEPID,PRSEZTA,SPOT,TMPADD,ADDSEQ
- Q
+ QUIT
+ ;  =========
 PV1(PSI) ;patient visit segment
  N PV1  ;hardcoded to letter O for Outpatient (Patient class)
@@ -133,5 +160,6 @@
  S ^TMP("PSO",$J,PSI)=PV1
  S PSI=PSI+1
- Q
+ QUIT
+ ;  =========
 PV2(PSI) ;patient visit segment (additional information)
  ;PATIENT STATUS AND COPAY
@@ -140,7 +168,9 @@
  S ^TMP("PSO",$J,PSI)="PV2|"_PV2
  S PSI=PSI+1
- Q
+ QUIT
+ ;  =========
 ORC(PSI) ;common order segment
- Q:'$D(DFN)
+ QUIT:'$D(DFN)
+ ;
  N ORC S ORC=""
  S $P(ORC,"|",1)="OE"
@@ -154,29 +184,46 @@
  S $P(ORC,"|",17)=CLN_CS_CLN1_CS_"99PSC"
  S $P(ORC,"|",19)=$S(CSINER'="":CSINER_CS_CSINER1,1:"")
- S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)_
+ ;  3080129 - RCR
+ ;  Segment 21 is incomplete.  Truncated.
+ ; S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)_
+ S $P(ORC,"|",21)=$P(SITE,"^",1)_CS_CS_$P(SITE,"^",6)
  S PSZIP=$P(SITE,"^",5) S PSOHZIP=$S(PSZIP["-":PSZIP,1:$E(PSZIP,1,5)_$S($E(PSZIP,6,9)]"":"-"_$E(PSZIP,6,9),1:""))
  S $P(ORC,"|",22)=$P(SITE,"^",2)_CS_CS_$P(SITE,"^",7)_CS_$S($D(^DIC(5,+$P(SITE,"^",8),0)):$P(^(0),"^",2),1:"UKN")_CS_PSOHZIP
  S $P(ORC,"|",23)="("_$P(SITE,"^",3)_")"_$P(SITE,"^",4)
  S ^TMP("PSO",$J,PSI)="ORC|"_ORC,PSI=PSI+1
- Q
+ QUIT
+ ;  ===========
 RXE(PSI) ;Pharmacy/treatment Encoded Order segment
- Q:'$D(DFN)
- N RXE S RXE=""
+ QUIT:'$D(DFN)
+ ;
+ N RXE,PSDRG10
+ S RXE=""
  S $P(RXE,"|",1)=""""""
- S $P(RXE,"|",2)=$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
+ S PSDRG10=$P($G(^PSDRUG(IDGN,"ND")),"^",10)
+ ;
+ ;  29JAN2008 - RCR ; The problem is tha/home/rcr/PSORELD1.mt the last $PIECE is incomplete.  This needs to be validated
+ ; S $P(RXE,"|",2)=$S($P($G(^PSDRUG(IDGN,"ND")),"^",10)'="":$P(^("ND"),"^",10),($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^"_CS_"99PSD"
+ S $P(RXE,"|",2)=$S(PSDRG10'="":PSDRG10,($G(PSND1)&$G(PSND3)):$P($G(PSOXN2),"^",2),1:"""""")_CS_$G(PSND2)_CS_"99PSNDF"_CS_PSND1_"."_PSND3_"."_$G(IDGN)_CS_$P($G(^PSDRUG(IDGN,0)),"^")_CS_"99PSD"
  S $P(RXE,"|",3)=""
  I $G(PSOXN)="" S PSOXN=""""""
  S $P(RXE,"|",5)=PSOXN_CS_$S($G(UNIT)'="":$G(UNIT),1:"""""")_CS_"99PSU"
- S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^") I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
+ S POIPTR=$P($G(^PSRX(IRXN,"OR1")),"^")
+ I POIPTR S PODOSE=$P($G(^PS(50.7,POIPTR,0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
  I '$G(POIPTR) S PODOSE=$P($G(^PS(50.7,$P($G(^PSDRUG(IDGN,2)),"^"),0)),"^",2),PODOSENM=$G(^PS(50.606,PODOSE,0))
  S TRADENM=$G(^PSRX(IRXN,"TN"))
  S $P(RXE,"|",6)=PODOSE_CS_PODOSENM_CS_"99PSF"
  S $P(RXE,"|",8)=MP
- S $P(RXE,"|",9)=TRADENM_
+ ;
+ ; 3080129 - RCR
+ ; Segment 9 is incomplete, truncated.
+ ; S $P(RXE,"|",9)=TRADENM_
+ S $P(RXE,"|",9)=TRADENM
  S $P(RXE,"|",15)=$P(^PSRX(IRXN,0),"^")
  S ^TMP("PSO",$J,PSI)="RXE|"_RXE,PSI=PSI+1
- Q
+ QUIT
+ ;  =========
 RXD(PSI) ;pharmacy dispense segment
- Q:'$D(DFN)
+ QUIT:'$D(DFN)
+ ;
  N RXD S RXD=""
  S $P(RXD,"|",1)=$S($G(NFLD):NFLD,1:0)
@@ -185,3 +232,4 @@
  S $P(RXD,"|",7)=$P(^PSRX(IRXN,0),"^")
  S $P(RXD,"|",9)=RELDT_RS_BINGO_RS_PSONDC
- Q
+ QUIT
+ ;  ========
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW.m	(revision 636)
@@ -1,4 +1,4 @@
-PSORENW ;BIR/SAB-renew main driver ;4/25/07 8:42am
- ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148,206**;DEC 1997;Build 39
+PSORENW ;BIR/SAB-renew main driver ;07/07/96
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,30,46,71,96,100,130,148**;DEC 1997
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
@@ -58,5 +58,6 @@
  I $P($G(^PSDRUG(PSODRG,2)),"^",3)'["O" Q "0^Drug is No longer used by Outpatient Pharmacy."
  I $G(^PSDRUG(PSODRG,"I"))]"",DT>$G(^("I")) Q "0^This Drug has been Inactivated."
- I ($P(PSODRUG0,"^",3)[1)!($P(PSODRUG0,"^",3)[2)!($P(PSODRUG0,"^",3)["W") Q "0^Non-Renewable "_$S($P(PSODRUG0,"^",3)["A":"Drug Narcotic.",1:"Drug.")
+ I $P(PSODRUG0,"^",3)["A",$P(PSODRUG0,"^",3)'["B" Q "0^Non-Renewable Drug Narcotic."
+ I $P(PSODRUG0,"^",3)["W" Q "0^Non-Renewable Drug."
  I $D(^PS(53,+$P(RX0,"^",3),0)),'$P(^(0),"^",5) Q "0^Non-Renewable Prescription."
  S PSOLC=$P(RX0,"^"),PSOLC=$E(PSOLC,$L(PSOLC)) I $A(PSOLC)'<90 Q "0^Max number of renewals (26) has been reached."
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORENW0.m	(revision 636)
@@ -1,4 +1,4 @@
-PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;4/24/07 9:05am
- ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237,206**;DEC 1997;Build 39
+PSORENW0 ;IHS/DSD/JCM-renew main driver continuation ;2/8/06 8:40am
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,32,59,64,46,71,96,100,130,237**;DEC 1997
  ;External reference to ^PS(50.7 supported by DBIA 2223
  ;External reference to ^PSDRUG supported by DBIA 221
@@ -58,5 +58,5 @@
  ;
  S (PSOS,PSOX,PSOY)="" K ACOM,DIR,DIRUT,DIRUT,DUOUT
- I $G(PSOSD) F  S PSOS=$O(PSOSD(PSOS)) Q:PSOS=""  F  S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG"))  I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $TR($P(PSOY,"^",3),"B")]"" D  K ACOM,DIR,DIRUT,DIRUT,DUOUT
+ I $G(PSOSD) F  S PSOS=$O(PSOSD(PSOS)) Q:PSOS=""  F  S PSOX=$O(PSOSD(PSOS,PSOX)) Q:PSOX']""!(PSORENW("DFLG"))  I PSORENW("OIRXN")=+PSOSD(PSOS,PSOX) S PSOY=PSOSD(PSOS,PSOX) I $P(PSOY,"^",3)]"" D  K ACOM,DIR,DIRUT,DIRUT,DUOUT
  . S PSORENW("DFLG")=1
  . W !,$C(7),"Cannot renew Rx # ",$P(PSORENW("RX0"),"^")
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORN52.m	(revision 636)
@@ -1,4 +1,20 @@
-PSORN52 ;BIR/DSD - files renewal entries in prescription file ;08/09/93
- ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201**;DEC 1997
+PSORN52 ;BIR/DSD - files renewal entries in prescription file ; 3/11/07 4:42pm
+ ;;7.0;OUTPATIENT PHARMACY;**1,11,27,37,46,79,71,100,117,157,143,219,148,239,201,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;Ext ref to ^PS(55 sup by DBIA 2228
  ;Ext ref to PSOUL^PSSLOCK sup by DBIA 2789
@@ -45,4 +61,5 @@
  I (PSOSCP<50&('$P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7))),$G(DUZ("AG"))="V" S PSOFLAG=0 D COPAY^PSOCPB
  ;I PSOSCP>49!($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1) S PSOFLAG=0 D SC^PSOMLLD2
+ I PSOAFYN="Y" G AFIN ;vfah
  I PSOSCA&(PSOSCP>49)!((PSOSCA!(PSOBILL=2))&($P($G(^PS(53,+$P(^PSRX(PSOX("IRXN"),0),"^",3),0)),"^",7)=1)) S PSOFLAG=0 D SC^PSOMLLD2
  I $$DT^PSOMLLDT D
@@ -56,5 +73,5 @@
  I $G(PSONEW("NEWCOPAY")) S ^PSRX(PSOX("IRXN"),"IB")=PSONEW("NEWCOPAY")
  ;
- D FINISH,ACP^PSOUTIL
+AFIN D FINISH,ACP^PSOUTIL ;vfah copay not evaluated by Autofinish,Rx
  ;
  N PSOSCFLD S PSOSCFLD=$S(PSOSCP'="":$G(PSOANSQ("SC")),1:"")_"^"_$G(PSOANSQ(PSOX("IRXN"),"MST"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"VEH"))_"^"_$G(PSOANSQ(PSOX("IRXN"),"RAD"))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORX1.m	(revision 636)
@@ -1,4 +1,20 @@
-PSORX1 ;BIR/SAB-medication processing driver ;3/28/05 1:14pm
- ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268**;DEC 1997;Build 9
+PSORX1 ;BIR/SAB-medication processing driver ; 1/7/07 3:32pm
+ ;;7.0;OUTPATIENT PHARMACY;**7,22,23,57,62,46,74,71,90,95,115,117,146,139,135,182,195,233,268,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference PDA^PPPPDA1 supported by DBIA 1374
  ;External reference ^PS(55 supported by DBIA 2228
@@ -38,6 +54,6 @@
  K NPPROC,PSOQFLG,DIC,DR,DIQ S DIC=2,DA=PSODFN,DR=.351,DIQ="PSOPTPST" D EN^DIQ1 K DIC,DA,DR,DIQ D DEAD^PSOPTPST I $G(PSOQFLG) S NOPROC=1 Q
  ;PSO*195 move SSN write to here and add DISPPRF call
- S SSN=$P(^DPT(PSODFN,0),"^",9) W !!?10,$C(7),PSORX("NAME")
- W " ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_")" K SSN
+ D ^VADPT W !!?10,$C(7),PSORX("NAME") ; correction for VOE
+ W " ",VA("PID") ; Correction with VOE, VA shouldn't be using SSN here!
  S PSONOAL="" D ALLERGY^PSOORUT2 D  I PSONOAL'="" D PAUSE
  .I PSONOAL'="" W !,$C(7),"     No Allergy Assessment!"
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXDL.m	(revision 636)
@@ -1,4 +1,4 @@
 PSORXDL ;BIR/SAB - Deletes one prescription ;06/10/96
- ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201,291**;DEC 1997;Build 2
+ ;;7.0;OUTPATIENT PHARMACY;**4,17,9,27,117,131,148,201**;DEC 1997
  ;External reference to ^PS(55 supported by DBIA 2228
  ;External references L, UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
@@ -7,7 +7,5 @@
  I '$D(^XUSEC("PSORPH",DUZ)) W !,$C(7),"Requires Pharmacy Key (PSORPH) !" Q
  I '$D(PSOPAR) D ^PSOLSET I '$D(PSOPAR) W $C(7),!!,"SITE PARAMETERS MUST BE DEFINED!",! Q
- K DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF
- S (PSDEL,PSOXXDEL)=1,PS="DELETE",DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))"
- D A1^PSORXVW K DIC("S") I $G(DA)<1 G KILL
+ K DA,PSODEFLG,PSOHLRE,PSOHLDAH,QTY,PSOABCDA,PSOREF S (PSDEL,PSOXXDEL)=1,PS="DELETE",DIC("S")="I $P($G(^(0)),""^"",2),$P($G(^(""STA"")),""^"")'=13,$G(^(2))" D A1^PSORXVW K DIC("S") G:'$G(DA) KILL
  D FULL^VALM1
  S RXN=+$G(DA)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXED.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXED.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXED.m	(revision 636)
@@ -1,4 +1,4 @@
-PSORXED ;IHS/DSD/JCM-edit rx utility ; 5/18/07 2:53pm
- ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201,246**;DEC 1997;Build 12
+PSORXED ;IHS/DSD/JCM-edit rx utility ;02/18/98  3:14 PM
+ ;;7.0;OUTPATIENT PHARMACY;**2,16,21,26,56,71,125,201**;DEC 1997
  ;External reference to ^PSXEDIT supported by DBIA 2209
  ;External reference to ^DD(52 supported by DBIA 999
@@ -24,5 +24,5 @@
 L1 D LOG,POST
 PROCESSX Q
-CHECK Q  L +^PSRX(PSORXED("IRXN")):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q
+CHECK Q  L +^PSRX(PSORXED("IRXN")):0 I '$T W $C(7),!!,"Rx Number is Locked by Another User!",! S PSORXED("DFLG")=1 H 5 Q
  I $G(^PSDRUG($P(PSORXED("RX0"),"^",6),"I"))]"",^("I")<DT D  G CHECKX
  . W !,$C(7),"This drug has been inactivated. ",! S PSORXED("DFLG")=1 Q
@@ -54,5 +54,5 @@
  I $L(PSORX("PSOL",PSOX2))+$L(PSORXED("IRXN"))<220 D  G LOGX
  .I PSORX("PSOL",PSOX2)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2)=PSORX("PSOL",PSOX2)_PSORXED("IRXN")_"," D SETRP
- E  I $G(PSORX("PSOL",PSOX2+1))'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP   ;;PSO*7*246
+ E  I PSORX("PSOL",PSOX2+1)'[PSORXED("IRXN")_"," S PSORX("PSOL",PSOX2+1)=PSORXED("IRXN")_"," D SETRP
 LOGX K PSOEDITF,PSOEDITR,PSOEDITL D:$G(RFED) ^PSORXED1
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL.m	(revision 636)
@@ -1,10 +1,13 @@
-PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;03/01/96  9:35
- ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148**;DEC 1997
- ;External reference to File #50 supported by DBIA 221
- ;External references CHPUS^IBACUS and TRI^IBACUS supported by DBIA 2030
+PSORXL ;BHAM ISC/SAB - action to be taken on prescriptions ;3/13/07  19:21
+ ;;7.0;OUTPATIENT PHARMACY;**8,21,24,32,47,135,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) GNU GPL 2007 WorldVistA
+ ;
+ ;Ext ref to File #50 supported by DBIA 221
+ ;Ext refs CHPUS^IBACUS and TRI^IBACUS supported by DBIA 203
  I $G(PSOTRVV),$G(PPL) S PSORX("PSOL",1)=PPL K PPL
  N SLBL,PSOSONE,PSOKLRXS
  S:'$G(PPL) PPL=$G(PSORX("PSOL",1)) G:$P(PSOPAR,"^",26) P
-LBL W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
+LBL I $G(PSOAFYN)'="Y" W !! S DIR("A",1)="Label Printer: "_$S($G(SUSPT):PSLION,1:$G(PSOLAP))
  S DIR("A")="LABEL: QUEUE/CHANGE PRINTER"_$S($P(PSOPAR,"^",23):"/HOLD",1:"")_$S($P(PSOPAR,"^",24):"/SUSPEND",1:"")_$S($P(PSOPAR,"^",26):"/LABEL",1:"")_" or '^' to bypass "
  S DIR("?",1)="Enter 'Q' to queue labels to print",DIR("?")="Enter '^' to bypass label functions",DIR("?",4)="Enter 'S' to suspend labels to print later"
@@ -12,5 +15,5 @@
  S DIR("?",5)="Enter 'C' to select another label printer"
  S:$P(PSOPAR,"^",26) DIR("?",5)="Enter 'L' to print labels without queuing"
-TRI ;Tricare
+TRI ;
  S X="IBACUS" X ^%ZOSF("TEST") K X I '$T G PASS
  I '$$TRI^IBACUS() G PASS
@@ -29,5 +32,5 @@
  I '$D(^TMP($J,"PSOBILL")) K ^TMP($J,"PSONOB") G PASS
  I '$D(^TMP($J,"PSONOB")),$D(^TMP($J,"PSOBILL")) S (Y,LBL)="H" G H1
- ;If some Rx's are billable, and some are not
+ ;
 SETP K PSORX("PSOL"),PPL S VVCT=1 F VV=0:0 S VV=$O(^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV)) Q:'VV  S TRIRX=^TMP($J,$S($G(PSTRIVAR):"PSONOB",1:"PSOBILL"),VV) I +TRIRX D
  .I $G(PSORX("PSOL",1))="" S PSORX("PSOL",1)=TRIRX_"," Q
@@ -37,8 +40,11 @@
  K ^TMP($J,"PSONOB") S PPL=$G(PSORX("PSOL",1))
 PASS ;
- I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
- S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D  G:$D(DIRUT)!($D(DUOUT)) EX
- .I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
- .I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
+ I $G(PSOAFYN)'="Y" I $E($G(DIR("A")),1,6)'="LABEL:" D RESDIR^PSOCPTRI
+ I $G(PSOAFYN)'="Y" S DIR(0)="SA^P:PROFILE;Q:QUEUE;C:CHANGE PRINTER"_$S($P(PSOPAR,"^",23):";H:HOLD",1:"")_$S($P(PSOPAR,"^",24):";S:SUSPENSE",1:"")_$S($P(PSOPAR,"^",26):";L:PRINT",1:""),DIR("B")="Q" D ^DIR D  G:$D(DIRUT)!($D(DUOUT)) EX
+ .I $G(PSOAFYN)'="Y" I $D(DIRUT)!($D(DUOUT)) D AL^PSOLBL("UT") I $G(PSOEXREP) S PSOEXREX=1
+ .I $G(PSOAFYN)'="Y" I $G(PSOPULL) I $D(DIRUT)!($D(DUOUT)) S PSOQFLAG=1
+ I $G(PSOAFYN)="Y" S PSOLAP=$G(^SC(+ORL,"AFRXCLINPRNT"))
+ I $G(PSOAFYN)="Y" I PSOLAP="" S DIRUT="^" G:$D(DIRUT)!($D(DUOUT)) EX
+ I $G(PSOAFYN)="Y" S PSOLAP=$P(^%ZIS(1,PSOLAP,0),"^",1)
  S:$G(PSOBEDT) NOPP=Y
  I $G(Y)="C" K PSOCLBL,%ZIS("B") S PSOCLBL=1 D @$S('$D(PSOPAR):"^PSOLSET",1:"PLBL^PSOLSET") K PSOCLBL G LBL
@@ -57,10 +63,10 @@
  D ^%ZISC S PSL=0
 QLBL I $G(PSXSYS),('$G(RXLTOP)),('$G(PSOEXREP)) D RXL^PSOCMOP G:'$G(PPL) D1
- ;
  ;- Submitting list of Rx to ECME for DUR/79 REJECT check and possible submission to 3rd Pary Payer
- D ECME^PSORXL1
+ I $G(PSOAFYN)'="Y" D ECME^PSORXL1 ;vfah
  ;
  S ZTRTN="DQ^PSOLBL",ZTIO=$S($G(SUSPT):PSLION,1:PSOLAP),ZTDESC="Outpatient Pharmacy "_$S($G(SUSPT):"SUSPENSE ",$G(DG):"DRUG INTERACTION ",1:"")_"LABELS OUTPUT ROUTINE",ZTDTH=$S($G(PSOTIME):PSOTIME,1:$H),PDUZ=DUZ
  F G="PPL1","PSOSYS","DFN","PSOPAR","PDUZ","PCOMX",$S($G(SUSPT):"PFION",1:"PSOLAP"),"PPL","PSOSITE","RXY","COPIES","SIDE","PSOSUSPR","PSOBARS","PSOBAR1","PSOBAR0","PSODELE","PSOPULL","PSTAT","PSODBQ","PSOEXREP","PSOTREP" S:$D(@G) ZTSAVE(G)=""
+ S ZTSAVE("PSOAFDFN")="",ZTSAVE("PSOAFDUZ")="",ZTSAVE("PSOAFYN")="",ZTSAVE("PSOAFPAT")="",ZTSAVE("PSOAFPNM")="",ZTSAVE("VFASDD")="",ZTSAVE("ORL")="" ;vfah
  S ZTSAVE("PSORX(")="",ZTSAVE("RXRP(")="",ZTSAVE("RXPR(")="",ZTSAVE("RXRS(")="",ZTSAVE("RXFL(")="",ZTSAVE("PCOMH(")=""
  D ^%ZISC,^%ZTLOAD K:$G(PSOSONE) RXRS W:$D(ZTSK)&('$G(SUSPT))&('$G(PSOEXREP)) !!,"LABEL(S) QUEUED TO PRINT",!!
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXL1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSORXL1 ;BIR/SAB-action to be taken on prescriptions ; 10/5/07 2:40pm
- ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260,274**;DEC 1997;Build 8
+PSORXL1 ;BIR/SAB-action to be taken on prescriptions ;03/01/96
+ ;;7.0;OUTPATIENT PHARMACY;**36,46,148,260**;DEC 1997;Build 84
 S S SPPL="",PPL1=1 S:'$G(PPL) PPL=$G(PSORX("PSOL",PPL1)) G:$G(PPL)']"" D1
 S1 F PI=1:1 Q:$P(PPL,",",PI)=""  S DA=$P(PPL,",",PI) D
@@ -33,6 +33,5 @@
  K COMM
 SUSQ Q
- ;PSO*7*274 allways recalculate RXF
-ACT S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
+ACT I '$D(RXF) S RXF=0 F I=0:0 S I=$O(^PSRX(DA,1,I)) Q:'I  S RXF=I S:I>5 RXF=I+1
  S IR=0 F FDA=0:0 S FDA=$O(^PSRX(DA,"A",FDA)) Q:'FDA  S IR=FDA
  S IR=IR+1,^PSRX(DA,"A",0)="^52.3DA^"_IR_"^"_IR
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXPA1.m	(revision 636)
@@ -1,7 +1,27 @@
-PSORXPA1 ;BIR/SAB - listman partial prescriptions ;07/14/93
- ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174**;DEC 1997
+PSORXPA1 ;BIR/SAB - listman partial prescriptions ; 1/15/07 5:42pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,56,77,130,152,181,174,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references L,UL, PSOL, and PSOUL^PSSLOCK supported by DBIA 2789
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External reference to ^DD(52 supported by DBIA 999
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y  ;vfah Quits if AUTOFINISH,RX not a user
+ I $P($G(^PSRX(RXN,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="Partial option is not available for Autofinshed Rxs" K PSOZAF Q  ;vfah
  I $D(RXRP($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Reprint Label has been requested!" Q
  ;I $D(RXPR($P(PSOLST(ORN),"^",2))) S VALMBCK="",VALMSG="A Partial has already been requested!" Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP1.m	(revision 636)
@@ -1,4 +1,20 @@
-PSORXRP1 ;BIR/SAB-rx speed reprint listman ;03/06/95
- ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148**;DEC 1997
+PSORXRP1 ;BIR/SAB-rx speed reprint listman ; 12/10/06 9:50pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,120,156,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 SEL N PSODISP,VALMCNT I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
@@ -25,4 +41,10 @@
  ;
 RX ;process reprint request
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P($G(^PSRX($P(PSOLST(ORN),"^",2),"OR1")),"^",5)=$G(PSOZAF) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" is an Autofinish,Rx and labels can not be reprinted." K PSOZAF D PAUSE^VALM1 Q  ;vfah
+ ;
  Q:$P(^PSRX($P(PSOLST(ORN),"^",2),"STA"),"^")>11
  I $$LMREJ^PSOREJU1($P(PSOLST(ORN),"^",2)) W $C(7),!!,"Rx "_$$GET1^DIQ(52,$P(PSOLST(ORN),"^",2),.01)_" has OPEN/UNRESOLVED 3rd Party Payer Rejects!" K DIR D PAUSE^VALM1 Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRP2.m	(revision 636)
@@ -1,4 +1,20 @@
-PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ;10/5/07 7:45am
- ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,280**;DEC 1997;Build 5
+PSORXRP2 ;BIR/SAB-main menu entry reprint of a Rx label ; 12/10/06 9:51pm
+ ;;7.0;OUTPATIENT PHARMACY;**11,27,120,138,135,156,185,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
  ;External reference ^PS(55 supported by DBIA 2228
@@ -9,4 +25,8 @@
  S (PPL,DA,RX,PSORPRX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
  D PSOL^PSSLOCK(PSORPRX) I '$G(PSOMSG) W !!,$S($P($G(PSOMSG),"^",2)'="":$P($G(PSOMSG),"^",2),1:"Another person is editing this order."),! K PSOMSG G LRP
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P(^PSRX(RX,"OR1"),"^",5)=$G(PSOZAF) W $C(7),!,"Cannot Reprint Labels for Autofinished Rxs" D ULR,KILL Q  ;vfah
  I $P(^PSRX(RX,"STA"),"^")=14 W $C(7),!,"Cannot Reprint! Discontinued by Provider." D ULR,KILL Q
  I $P(^PSRX(RX,"STA"),"^")=15 W $C(7),!,"Cannot Reprint! Discontinued due to editing." D ULR,KILL Q
@@ -54,6 +74,5 @@
  E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
  K D,BSIG
- ;PSO*7*280 If Trade name, don't lookup in ^PSDRUG
- W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
+ W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
  W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
  I $G(RX) D
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXRPT.m	(revision 636)
@@ -1,4 +1,20 @@
-PSORXRPT ;BIR/SAB-reprint of a prescription label ;9/20/07 9:40am
- ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,280**;DEC 1997;Build 5
+PSORXRPT ;BIR/SAB-reprint of a prescription label ; 12/10/06 8:42pm
+ ;;7.0;OUTPATIENT PHARMACY;**3,21,27,34,120,138,156,148,208**;DEC 1997;Build 39
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to ^PSDRUG supported by DBIA 221
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
@@ -14,4 +30,10 @@
  .S RX=$P(PSOLST(ORN),"^",2) D VALID^PSORXRP1 S:$G(QFLG) VALMBCK="",VALMSG="A New Label has been requested already!"
  S (PPL,DA,RX)=+Y,PDA=Y(0),RXF=0,ZD(DA)=DT,REPRINT=1,STA=+$G(^PSRX(+Y,"STA"))
+ ;
+ S DIC="^VA(200,",DIC(0)="QEZ",X="AUTOFINISH,RX" ;vfah
+ D ^DIC K DIC ;vfah
+ S PSOZAF=+Y ;vfah
+ I $P($G(^PSRX(RX,"OR1")),"^",5)=$G(PSOZAF) S VALMBCK="",VALMSG="This reprint option is not available for Autofinshed Rxs",QFLG=1 K PSOZAF D ULR,KILL Q  ;vfah
+ ;
  I $P(^PSRX(RX,"STA"),"^")=14 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued by Provider.",QFLG=1 D ULR,KILL Q
  I $P(^PSRX(RX,"STA"),"^")=15 S VALMBCK="",VALMSG="Cannot Reprint! Discontinued due to editing.",QFLG=1 D ULR,KILL Q
@@ -55,6 +77,5 @@
  E  D EN3^PSOUTLA1(DA,75) S D=0 F  S D=$O(BSIG(D)) W !,BSIG(D) Q:'$O(BSIG(D))
  K D,BSIG
- ;PSO*7*280 If trade name is used Stop the DRUG Lookup.
- W !!,$S($G(^PSRX(DA,"TN"))]"":P(6),(P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
+ W !!,$S((P(6)=+P(6))&$D(^PSDRUG(P(6),0)):$P(^(0),"^"),1:P(6)),! S PHYS=$S($D(^VA(200,+P(4),0)):$P(^(0),"^"),1:"Unknown") W PHYS K PHYS
  W ?25,$S($D(^VA(200,+P(16),0)):$P(^(0),"^"),1:"Unknown"),!,"# of Refills: "_$G(P(9))
  I $G(RX) S RXFL(RX)=0 F ZZZ=0:0 S ZZZ=$O(^PSRX(RX,1,ZZZ)) Q:'ZZZ  S RXFL(RX)=ZZZ
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW.m	(revision 636)
@@ -1,4 +1,4 @@
 PSORXVW ;BHAM ISC/SAB - listman view of a prescription ;5/25/05 2:10pm
- ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**14,35,46,96,103,88,117,131,146,156,185,210,148,233,260,264**;DEC 1997;Build 19
  ;External reference to File ^PS(55 supported by DBIA 2228
  ;External reference to ^PS(50.7 supported by DBIA 2223
@@ -107,8 +107,8 @@
  S VALM("TITLE")="Rx View "_"("_$P("Error^Active^Non-Verified^Refill^Hold^Non-Verified^Suspended^^^^^Done^Expired^Discontinued^Deleted^Discontinued^Discontinued (Edit)^Provider Hold^","^",ST+2)_")"
  S:$P($G(^PSRX(DA,"PKI")),"^") VALMSG="Digitally Signed Order"
- D EN^PSOORAL,KILL I $G(PS)="VIEW" G PSORXVW
+ D EN^PSOORAL,KILL G:PS="VIEW" PSORXVW
  Q
  ;
-KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) I $G(PS)="VIEW" K DA
+KILL K ^TMP("PSOAL",$J),PSOAL,IEN,^TMP("PSOHDR",$J) K:PS="VIEW" DA
  K ST,RFL,RFLL,RFL1,ST,II,J,N,PHYS,L1,DIRUT,PSDIV,PSEXDT,MED,M1,FFX,DTT,DAT,RX0,RX2,R3,RTN,SIG,STA,P1,PL,P0,Z0,Z1,EXDT,IFN,DIR,DUOUT,DTOUT,PSOELSE
  K LBL,I,RFDATE,%H,%I,RN,RFT,%,%I,DFN,GMRA,GMRAL,HDR,POERR,PTST,REFL,RF,RLD,RX3
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSORXVW1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSORXVW1 ;BIR/SAB-view prescription con't ; 12/4/07 12:28pm
- ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260,240,281**;DEC 1997;Build 41
+PSORXVW1 ;BIR/SAB-view prescription con't ;5/26/05 10:07am
+ ;;7.0;OUTPATIENT PHARMACY;**35,47,46,71,99,117,156,193,210,148,258,260**;DEC 1997;Build 84
  ;External reference to ^DD(52 supported by DBIA 999
  ;External reference to ^VA(200 supported by DBIA 10060
@@ -43,11 +43,11 @@
  .I $P(P1,"^",5)]"" N PSOACBRK,PSOACBRV D
  ..S PSOACBRV=$P(P1,"^",5)
- ..;PSO*7*240 Use fileman to format
- ..K ^UTILITY($J,"W") S X="Comments: "_PSOACBRV,(DIWR,DIWL)=1,DIWF="C80" D ^DIWP F I=1:1:^UTILITY($J,"W",1) S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$G(^UTILITY($J,"W",1,I,0))
+ ..I $L(PSOACBRV)<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_PSOACBRV Q
+ ..I $E(PSOACBRV,1,70)'[" " S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,70),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,71,245) Q
+ ..F PSOACBRK=245:-1 Q:PSOACBRK=0  I $E(PSOACBRV,PSOACBRK)=" ",PSOACBRK<71 S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Comments: "_$E(PSOACBRV,1,PSOACBRK),IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=$E(PSOACBRV,PSOACBRK,245) Q
  .I $G(^PSRX(DA,"A",N,1))]"" S IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",5)=$P(^PSRX(DA,"A",N,1),"^") I $P(^PSRX(DA,"A",N,1),"^",2)]"" S ^TMP("PSOAL",$J,IEN,0)=^TMP("PSOAL",$J,IEN,0)_":"_$P(^PSRX(DA,"A",N,1),"^",2)
  .I $O(^PSRX(DA,"A",N,2,0)) F I=0:0 S I=$O(^PSRX(RXN,"A",N,2,I)) Q:'I  S MIG=^PSRX(RXN,"A",N,2,I,0) D
  ..F SG=1:1:$L(MIG) S:$L(^TMP("PSOAL",$J,IEN,0)_" "_$P(MIG," ",SG))>80 IEN=IEN+1,$P(^TMP("PSOAL",$J,IEN,0)," ",9)=" " S:$P(MIG," ",SG)'="" ^TMP("PSOAL",$J,IEN,0)=$G(^TMP("PSOAL",$J,IEN,0))_" "_$P(MIG," ",SG)
- K MIG,SG,I,^UTILITY($J,"W"),DIWF,DIWL,DIWR
- Q
+ K MIG,SG,I Q
 LBL ;label log
  S IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)=" ",IEN=IEN+1,^TMP("PSOAL",$J,IEN,0)="Label Log:"
@@ -121,7 +121,6 @@
  ;
 HLP ; Help Text for the VIEW PRESCRIPTION prompt 
- W !," A prescription number or ECME # may be entered.  The ECME"
- W !," number must be entered in E.NNNNNNN format, where NNNNNNN"
- W !," is the prescription ECME # (example: E.0289332).  Or just"
+ W !," You may enter E.NNNNNNN, where NNNNNNN is the"
+ W !," prescription ECME# (e.g., E.0289332) or,"
  D LKP("?")
  Q 
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD0.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;6/21/07 8:20am
- ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258,206**;DEC 1997;Build 39
+PSOSD0 ;BHAM ISC/SAB - action or informational profile cont. ;3/24/93
+ ;;7.0;OUTPATIENT PHARMACY;**2,19,40,66,107,110,258**;DEC 1997;Build 4
  ;External reference to ^PS(50.605 supported by DBIA 696
  ;External reference to ^SC supported by DBIA 10040
@@ -39,5 +39,5 @@
  I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
  G:$G(DOD(DFN))]"" RXN2
- D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
+ D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
  S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
  W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
@@ -80,5 +80,5 @@
  I 'PSTYPE D:$D(^PSDRUG(+$P(RX0,"^",6),"CLOZ"))&($P($G(^("CLOZ1")),"^")'="PSOCLO1") ^PSOLAB G RXN2
  G:$G(DOD(DFN))]"" RXN3
- D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["1",PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
+ D:+$G(PSOBAR4) BAR S PSRENW=0,PSODEA=$P($G(^PSDRUG(+$P(RX0,"^",6),0)),"^",3) I PSODEA'["2",PSODEA'["W",$P($G(^PS(53,+$P(RX0,"^",3),0)),"^",5) S PSRENW=1
  S PSOIFSUP=$S(PSODEA']"":0,PSODEA["S":1,1:0),RXX=$P(RX0,"^"),RXX(1)="",RXX=$O(^PSRX("B",RXX,RXX(1)))
  W:$P($G(^PSRX(RXX,"IB")),"^") !?11,"****COPAY****" D PSRENW^PSOSD2
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSD1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ; 10/30/07 10:39am
- ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258,240**;DEC 1997;Build 5
+PSOSD1 ;BHAM ISC/SAB/JMB - action or informational profile cont. ;11/18/92
+ ;;7.0;OUTPATIENT PHARMACY;**2,17,19,22,40,49,66,107,110,132,233,258**;DEC 1997;Build 4
  ;External reference to ^PS(59.7 is supported by DBIA 694
  ;
@@ -25,5 +25,5 @@
  D KVA^VADPT K DOD,FILL,DIC,PSCNT,PSDT,PCLASS,PHYS,ZCLASS,PSOPRINT,RXNODE,DIR,X1,X2,PSONUM,PSOPOLP,PSSN4
  Q
- ; 
+ ;
 DAYS K DIR S DIR("A")="Profile Expiration/Discontinued Cutoff",DIR("B")=120,DIR(0)="N^0:9999:0",DIR("?",1)="Enter the number of days which will cut discontinued and expired Rx's from",DIR("?")="the profile."
  D ^DIR Q:$D(DTOUT)!($D(DUOUT))  S PSDAYS=X K DIR S X1=DT,X2=-PSDAYS D C^%DTC S (PSDATE,PSDAY)=X
@@ -86,6 +86,5 @@
  K DIR,DTOUT,DIRUT,DUOUT S DIR("A")="Do you want this Profile to print in 132 columns or 80 columns: ",DIR("B")="132",DIR(0)="SAM^1:132;8:80;E:Exit"
  D ^DIR G:Y="E"!($D(DUOUT))!($D(DIRUT)) EXIT S PSORM=$S(Y=1:1,1:0) K DIR,X,Y
- ;PSO*7*240 Go to exit if DUOUT or DTOUT
-ASK D DAYS G:($D(DUOUT))!($D(DTOUT)) EXIT S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
+ASK D DAYS S PRF=PSODFN_"," D DEV I $D(ZTSK) S VALMSG="Action Profile Queued to Printer."
  D EXIT K LM
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSIGMX.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ; 7/25/07 11:17am
- ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222,206**;DEC 1997;Build 39
+PSOSIGMX ;BIR/RTR-Utility routine to calculate Max Refills for CPRS ;12/28/00
+ ;;7.0;OUTPATIENT PHARMACY;**46,78,108,131,222**;DEC 1997;Build 12
  ;External reference to PS(55 supported by DBIA 2228
  ;External reference to PSDRUG( supported by DBIA 221
@@ -37,5 +37,5 @@
  .I PSOCDEA["2"!(PSOCDEA["3")!(PSOCDEA["4")!(PSOCDEA["5") S PSOCSX=1
  I PSOCSX D
- .S PSOQX("MAX")=$S((PSOCDEA[1)!(PSOCDEA[2):0,1:5),PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=5:PSOQX("MAX"),1:PSOMX1)
+ .S PSOQX("MAX")=$S(PSOCDEA["2":0,1:5),PSOMX1=$S($G(PSOMXRX)>PSOQX("MAX"):PSOQX("MAX"),1:$G(PSOMXRX)),PSOQX("MAX")=$S(PSOMX1=5:PSOQX("MAX"),1:PSOMX1)
  .S PSOQX("MAX")=$S('PSOQX("MAX"):0,$G(PSOQX("DAYS SUPPLY"))=90:1,1:PSOQX("MAX")),PSODYX=$G(PSOQX("DAYS SUPPLY")),PSODYX1=$S(PSODYX<60:5,PSODYX'<60&(PSODYX'>89):2,PSODYX=90:1,1:0) S PSOQX("MAX")=$S(PSOQX("MAX")'>PSODYX1:PSOQX("MAX"),1:PSODYX1)
  I 'PSOCSX!('$G(PSOQX("DRUG"))) D
@@ -45,7 +45,7 @@
  .S PSOMXPAT=$O(^YSCL(603.01,"C",+$G(PSOQX("PATIENT")),0)) I 'PSOMXPAT S PSOQX("MAX")=0 Q
  .S PSOMXPAT=$P($G(^YSCL(603.01,PSOMXPAT,0)),"^",3)
- .I $D(PSOQX("DAYS SUPPLY")) S PSOQX("MAX")=$S(PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY"))<8):3,PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY"))<15):1,PSOMXPAT="B"&($G(PSOQX("DAYS SUPPLY"))<8):1,1:0) Q
+ .I $D(PSOQX("DAYS SUPPLY")) S PSOQX("MAX")=$S(PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY")))<8:3,PSOMXPAT="M"&($G(PSOQX("DAYS SUPPLY")))<15:1,PSOMXPAT="B"&($G(PSOQX("DAYS SUPPLY")))<8:1,1:0) Q
  .S PSOQX("MAX")=$S(PSOMXPAT="M":3,PSOMXPAT="B":1,1:0)
- I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F")!(PSOCDEA[1)!(PSOCDEA[2) S PSOQX("MAX")=0
+ I $G(PSOQX("DRUG")) I PSOCDEA["A"&(PSOCDEA'["B")!(PSOCDEA["F") S PSOQX("MAX")=0
  I PSONODD S PSOQX("DRUG")=0
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOSUPOE.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOSUPOE ;BIR/RTR - Suspense pull via Listman ;3/1/96
- ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**8,21,27,34,130,148**;DEC 1997
  ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
 SEL I '$G(PSOCNT) S VALMSG="This patient has no Prescriptions!" S VALMBCK="" Q
@@ -41,5 +41,5 @@
  . D ECMESND^PSOBPSU1(RXREC,RFL,,"PP")
  . I $$FIND^PSOREJUT(RXREC,RFL) D
- . . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(RXREC,RFL,"79,88","PP","IOQ","I")
  ;
  D ULRX K PSOGET,PSOGETF
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCAN.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCAN.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOTPCAN.m	(revision 636)
@@ -1,4 +1,20 @@
-PSOTPCAN ;BIR/RTR - TPB Utility routine ;08/23/03
- ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227**;DEC 1997
+PSOTPCAN ;BIR/RTR - TPB Utility routine ;3/13/07  21:21
+ ;;7.0;OUTPATIENT PHARMACY;**146,153,163,227,208**;DEC 1997;Build 39
+ ; Modified from FOIA VistA
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;External reference to PS(55 supported by DBIA 2228
  ;External reference to VA(200 supported by DBIA 224
@@ -114,5 +130,5 @@
  . S PSOTPWR1=$P($G(^PSRX(+$P(^PS(52.41,PSOTPWRN,0),"^",21),0)),"^",3)
  . S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^"),PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
- . I PSOTPWR3="NON-VA" D
+ . I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
  . . K DIR W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue" D ^DIR K DIR
  . . Q
@@ -120,5 +136,5 @@
  S PSOTPWR1=$P($G(^PS(55,+$P($G(^PS(52.41,PSOTPWRN,0)),"^",2),"PS")),"^")
  S PSOTPWR2=$P($G(^PS(53,+PSOTPWR1,0)),"^") S PSOTPWR3=$$UP^XLFSTR(PSOTPWR2)
- I PSOTPWR3="NON-VA" D
+ I PSOTPWR3="NON-VA",DUZ("AG")="V" D  ; Skip for VOE sites
  .W !!,"This order has an Rx Patient Status of 'NON-VA'!",! K DIR S DIR(0)="E",DIR("A")="Press return to continue"  D ^DIR K DIR
  Q
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOUTLA1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;5/22/07 10:01am
- ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259,206**;DEC 1997;Build 39
+PSOUTLA1 ;BHAM ISC/RTR-Pharmacy utility program cont. ;10/20/06 3:44pm
+ ;;7.0;OUTPATIENT PHARMACY;**35,186,218,259**;DEC 1997;Build 5
  ;External reference to File ^PS(55 supported by DBIA 2228
  ;External reference to File ^PSDRUG supported by DBIA 221
@@ -109,5 +109,5 @@
  ;
  ;no refills if PSDEA = 'A' & not 'B' or 'F',
- I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F")!(PSDEA[1)!(PSDEA[2) D  Q 1
+ I (PSDEA["A")&(PSDEA'["B")!(PSDEA["F") D  Q 1
  . S PSMAXRF=$$NUMFILLS(PSIRXN)
  ;
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVER1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVER1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOVER1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSOVER1 ;BHAM ISC/SAB - verify one rx ;3/9/05 12:53pm
- ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268,281**;DEC 1997;Build 41
+ ;;7.0;OUTPATIENT PHARMACY;**32,46,90,131,202,207,148,243,268**;DEC 1997;Build 9
  ;External reference ^PSDRUG( supported by DBIA 221
  ;External reference to PSOUL^PSSLOCK supported by DBIA 2789
@@ -78,5 +78,5 @@
  . S ACTION="" D ECMESND^PSOBPSU1(PSONV,,,$S($O(^PSRX(PSONV,1,0)):"RF",1:"OF"))
  . I $$FIND^PSOREJUT(PSONV) D
- . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","Q")
+ . . S ACTION=$$HDLG^PSOREJU1(PSONV,0,"79,88","OF","IOQ","I")
  ;
 KILL S DA=PSONV,DIK="^PS(52.4," D ^DIK K DA,DIK D DCORD^PSONEW2
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 05/26/08
+PSOXZA ; DRIVER FOR COMPILED XREFS FOR FILE #52 ; 01/17/08
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA1.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 05/26/08
+PSOXZA1 ; COMPILED XREF FOR FILE #52 ; 01/17/08
  ; 
  S DIKZK=2
@@ -75,5 +75,5 @@
  . S:$D(DIKIL) (X2,X2(1))=""
  . K ^PSRX("APKI",$E(X,1,30),DA)
-CR3 S DIXR=461
+CR3 S DIXR=476
  K X
  S DIKZ(0)=$G(^PSRX(DA,0))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA10.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 05/26/08
+PSOXZA10 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA11.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 05/26/08
+PSOXZA11 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08
  ; 
  S DA=0
@@ -30,5 +30,5 @@
  S X=$P(DIKZ(0),U,18)
  I X'="" I +$G(^PSRX(DA(1),"IB")) K:$P($G(^PSRX(DA(1),1,DA,0)),"^")&($P($G(^(0)),"^",18)) ^PSRX("ACP",$P(^PSRX(DA(1),0),"^",2),$P(^PSRX(DA(1),1,DA,0),"^"),DA,DA(1))
-CR1 S DIXR=462
+CR1 S DIXR=477
  K X
  S X(1)=$P(DIKZ(0),U,10)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA12.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 05/26/08
+PSOXZA12 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08
  ; 
  S DA=0
@@ -16,5 +16,5 @@
  S X=$P(DIKZ(0),U,19)
  I X'="" S ^PSRX("AM",$E(X,1,30),DA(1),DA)=""
-CR1 S DIXR=463
+CR1 S DIXR=478
  K X
  S X(1)=$P(DIKZ(0),U,10)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA13.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 05/26/08
+PSOXZA13 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08
  ; 
  S DA=0
@@ -10,5 +10,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" S ^PSRX(DA(1),"REJ","B",$E(X,1,30),DA)=""
-CR1 S DIXR=652
+CR1 S DIXR=224
  K X
  S X(1)=$P(DIKZ(0),U,2)
@@ -17,5 +17,5 @@
  . K X1,X2 M X1=X,X2=X
  . S ^PSRX("REJDAT",X,DA(1),DA)=""
-CR2 S DIXR=653
+CR2 S DIXR=225
  K X
  S DIKZ(0)=$G(^PSRX(DA(1),"REJ",DA,0))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA14.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 05/26/08
+PSOXZA14 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA2.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 05/26/08
+PSOXZA2 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA3.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 05/26/08
+PSOXZA3 ; COMPILED XREF FOR FILE #52.052311 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA4.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 05/26/08
+PSOXZA4 ; COMPILED XREF FOR FILE #52.1 ; 01/17/08
  ; 
  S DA=0
@@ -30,5 +30,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" I +$G(^PSRX(DA(1),"IB")) K:$P($G(^PSRX(DA(1),0)),"^",2)&($P($G(^PSRX(DA(1),1,DA,0)),"^",2)="W")&('$P($G(^(0)),"^",16))&('$P($G(^(0)),"^",18))&('$G(^("IB"))) ^PSRX("ACP",$P(^PSRX(DA(1),0),"^",2),X,DA,DA(1))
-CR1 S DIXR=462
+CR1 S DIXR=477
  K X
  S DIKZ(0)=$G(^PSRX(DA(1),1,DA,0))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA5.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 05/26/08
+PSOXZA5 ; COMPILED XREF FOR FILE #52.2 ; 01/17/08
  ; 
  S DA=0
@@ -18,5 +18,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" D:'$G(PSOSUSPA) PARKILL^PSOUTLA
-CR1 S DIXR=463
+CR1 S DIXR=478
  K X
  S X(1)=$P(DIKZ(0),U,10)
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA6.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 05/26/08
+PSOXZA6 ; COMPILED XREF FOR FILE #52.25 ; 01/17/08
  ; 
  S DA=0
@@ -10,5 +10,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PSRX(DA(1),"REJ","B",$E(X,1,30),DA)
-CR1 S DIXR=652
+CR1 S DIXR=224
  K X
  S X(1)=$P(DIKZ(0),U,2)
@@ -18,5 +18,5 @@
  . S:$D(DIKIL) (X2,X2(1))=""
  . K ^PSRX("REJDAT",X,DA(1),DA)
-CR2 S DIXR=653
+CR2 S DIXR=225
  K X
  S DIKZ(0)=$G(^PSRX(DA(1),"REJ",DA,0))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA7.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 05/26/08
+PSOXZA7 ; COMPILED XREF FOR FILE #52.2551 ; 01/17/08
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA8.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 05/26/08
+PSOXZA8 ; COMPILED XREF FOR FILE #52 ; 01/17/08
  ; 
  S DIKZK=1
@@ -77,5 +77,5 @@
  . K X1,X2 M X1=X,X2=X
  . I +$P($G(^PSRX(DA,"PKI")),"^")=1 S ^PSRX("APKI",$E(X,1,30),DA)=""
-CR3 S DIXR=461
+CR3 S DIXR=476
  K X
  S DIKZ(0)=$G(^PSRX(DA,0))
Index: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m
===================================================================
--- FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m	(revision 631)
+++ FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOXZA9.m	(revision 636)
@@ -1,3 +1,3 @@
-PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 05/26/08
+PSOXZA9 ; COMPILED XREF FOR FILE #52.01 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/PAID-PRS/PRS8AC.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8AC.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8AC.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8AC ;HISC/MRL-DECOMPOSITION, ACTIVITY STRING ;05/18/07
- ;;4.0;PAID;**40,45,54,52,69,75,90,96,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8AC ;HISC/MRL-DECOMPOSITION, ACTIVITY STRING ;01/22/04
+ ;;4.0;PAID;**40,45,54,52,69,75,90,96**;Sep 21, 1995
  ;
  ;The primary purpose of this routine is to create the activity
@@ -16,11 +15,9 @@
  S Q=0
  I DY>0,DY<15 D  G END:Q
- .I DAY(DY,"OFF"),"LSWARUHFGDr"[VAR S Q=1 ;exc invalid day off VAR
+ .I DAY(DY,"OFF"),"LSWARUHFGD"[VAR S Q=1 ;exc invalid day off VAR
  K OC,FLAG
  ;
  S DAYZ=DAY(DY,"W")_$G(DAY(DY,"N")),MTM=0
  S DAYH=$G(DAY(DY,"HOL"))_$G(DAY(DY+1,"HOL")) ;holiday node
- N DAYR
- S DAYR=DAY(DY,"r")_$G(DAY(DY,"rN")) ; Recess
  ;
  ;P 45 FIREFIGHTERS F NODE TO TRACK ADDITIONAL FF HRS
@@ -29,6 +26,4 @@
  F T=+V:1:+$P(V,"^",2) D
  .I +VAR,$E(DAYH,T),$E(DAYZ,T)?1A Q  ;no override holiday
- .; Don't override Recess but allow Unscheduled Regular (VAR=4)
- .I +VAR,VAR'=4,$E(DAYR,T)="r" Q  ; don't override Recess
  .I VAR="A"&(JURY=1) S VAR="J"
  .S VAR1=VAR Q:VAR1=""  S DAYZ(1)=$E(DAYZ,T)
@@ -37,10 +32,5 @@
  .I T=+V,"Vh"[VAR1,TYP["I" S DAY(DY,"DWK")=1 ;count days worked for cop
  .I "JLSWNnARUXYFGD"[VAR1,T'>96,'$E(DAYZ,T) Q  ;invalid outside tour
- .; Regular employees can't earn ct/use ot during work
- .I +NAWS'=9,"EOPQT4"[VAR1,T'>96,$E(DAYZ,T) Q
- .; 9mo AWS checks
- .I +NAWS=9,"PQT"[VAR1,T'>96,$E(DAYZ,T) Q  ;can't earn ct/use ot during work
- .; Allow CT/OT/UN/ON if posted over Recess otherwise don't allow
- .I +NAWS=9,"4OEC"[VAR1,T'>96,$E(DAYZ,T),$E(DAYR,T)'="r" S $E(DAYR,T)=VAR1 Q
+ .I "EOPQT4"[VAR1,T'>96,$E(DAYZ,T) Q  ;can't earn ct/use ot during work
  .I "OE"[VAR1,"BC"[DAYZ(1),$L(DAYZ(1)) D  ; Change OT or CT to CB/SB OT
  ..S VAR1=$C($A($E(DAYZ,T))+32)
@@ -54,30 +44,9 @@
  .I $E(DAYZ,T)=5,"ALSRUFGD"[VAR1 S VAR1=$E(DAYZ,T)
  .I $E(DAYZ,T)="-","BbCctes"[VAR1 Q  ;unavail for oc/sb or sch ot/ct
- .;
- .I VAR'="r" D
- ..S DAYZ=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999)
- ..I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) D
- ...S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_VAR1_$E(DAY(DY-1,"N"),T+1,999) ;save VAR
- ..; When processing tour time also copy tour into DAYR
- ..I "1235"[VAR1 D
- ...S DAYR=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999)
- ...I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) D
- ....S DAY(DY-1,"rN")=$E(DAY(DY-1,"rN"),0,T-1)_VAR1_$E(DAY(DY-1,"rN"),T+1,999)
- .;
- .; The following check will record Recess and will then update VAR1 to 0 which
- .; will result in the normally scheduled tour being marked as being no tour.
- .; This will allow Unscheduled Regular, OT and CT to be posted over the tour.
- .I VAR="r" D
- ..S DAYR=$E(DAYR,0,T-1)_VAR1_$E(DAYR,T+1,999)
- ..S DAYZ=$E(DAYZ,0,T-1)_0_$E(DAYZ,T+1,999) ; Overwrite tour
- ..I $E($G(DAY(DY-1,"rN")),T)'="",VAR1'=$E($G(DAY(DY-1,"rN")),T) D
- ...S DAY(DY-1,"rN")=$E(DAY(DY-1,"rN"),0,T-1)_VAR1_$E(DAY(DY-1,"rN"),T+1,999)
- ...S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_0_$E(DAY(DY-1,"N"),T+1,999)
- ..S Y=48 D SET ; Count Recess
- .;
+ .S DAYZ=$E(DAYZ,0,T-1)_VAR1_$E(DAYZ,T+1,999) I $E($G(DAY(DY-1,"N")),T)'="",VAR1'=$E($G(DAY(DY-1,"N")),T) S DAY(DY-1,"N")=$E(DAY(DY-1,"N"),0,T-1)_VAR1_$E(DAY(DY-1,"N"),T+1,999) ;save VAR
  .I VAR1="J" S Y=5 D SET ;set authorized absence for jury duty
  .I VAR1="M" S Y=5 D SET ; authorized absence for ML
  .;ot on non-premium T&L
- .I ("Eocb"[VAR1!(VAR1="O"&'$E(DAYH,T)))&("^^10^11^12^13^15^16^17^"[("^"_$P(V,"^",4)_"^"))!(VAR1=5&("ALSRUFGD"[VAR))!(VAR1=4&(TYP["P"!(TYP["I"&(TYP["N"!(TYP["H"!($$HYBRID^PRSAENT1($G(DFN)))))))&("^7^9^11^12^14^17^"[("^"_$P(V,"^",4)_"^"))) D
+ .I ("Eocb"[VAR1!(VAR1="O"&'$E(DAYH,T)))&("^^10^11^12^13^15^16^"[("^"_$P(V,"^",4)_"^"))!(VAR1=5&("ALSRUFGD"[VAR))!(VAR1=4&(TYP["P"!(TYP["I"&(TYP["N"!(TYP["H"!($$HYBRID^PRSAENT1($G(DFN)))))))&("^7^9^11^12^14^"[("^"_$P(V,"^",4)_"^"))) D
  ..Q:$E(DAY(DY,"P"),T)=5&("ALSRUFGD"'[VAR)
  ..I $D(FLAG) S FLAG=VAR1,VAR1=5
@@ -89,5 +58,4 @@
  ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&(TYP'["N")&(TYP'["H")&('$$HYBRID^PRSAENT1($G(DFN))) S CODE="n" Q
  ...I "^7^8^9^11^"[("^"_$P(V,"^",4)_"^")&("^S^T^U^V^"'[(U_PMP_U)) S CODE="n" Q
- ...I $P(V,"^",4)=17 S CODE="N" Q  ; Code 17 - OT/CT with premiums 
  ...I VAR1=5 S CODE=VAR Q
  ...S CODE=1
@@ -125,11 +93,10 @@
  ..K S,VAR1
  ;
+ ;
  S DAY(DY,"W")=$E(DAYZ,1,96) ;todays activity
  S DAY(DY,"N")=$E(DAYZ,97,999) ;tomorrows activity from today/if any
- S DAY(DY,"r")=$E(DAYR,1,96) ; Today's Recess
- S DAY(DY,"rN")=$E(DAYR,97,999) ; Tomorrow's Recess/if any
  S:$E(DAY(DY,"P"),97,999)'="" DAY(DY,"P1")=$E(DAY(DY,"P"),97,999) ;non-prem ot for next day
  S DAY(DY,"P")=$E(DAY(DY,"P"),1,96) ;non-prem ot for today
- I DAY(DY,"N")?1"0"."0",DAY(DY,"rN")'["r" S DAY(DY,"N")=""
+ I DAY(DY,"N")?1"0"."0" S DAY(DY,"N")=""
  S DAY(DY,"HOL")=$E(DAYH,1,96)
  ;
@@ -167,7 +134,4 @@
  .S X=DAY(DY-1,"P1")_$E(DAY(DY,"P"),$L(DAY(DY-1,"P1"))+1,96)
  .S DAY(DY,"P")=X
- I $D(DAY(DY-1,"rN")),$L(DAY(DY-1,"rN")) D
- .S X=DAY(DY-1,"rN")_$E(DAY(DY,"r"),$L(DAY(DY-1,"rN"))+1,96)
- .S DAY(DY,"r")=X
  ;
 END ; --- all done here
Index: FOIAVistA/tag/r/PAID-PRS/PRS8CR.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8CR.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8CR.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;01/17/07
- ;;4.0;PAID;**2,6,45,69,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8CR ;HISC/MRL-DECOMPOSITION, CREATE STRING ;8/23/01
+ ;;4.0;PAID;**2,6,45,69**;Sep 21, 1995
  ;
  ;This routine take the information contained in the WK array
@@ -17,16 +16,12 @@
  N MLINHRS
  S MLINHRS=$$MLINHRS^PRSAENT(DFN)
- S S="333333333333333333333333333333333443623233333333333"
- S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA  EB  TATCFAFCADNTRSSRSDND"
- S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC  ED  TBTDFBFDAFNHRNSSSHNU"
+ S S="33333333333333333333333333333333344362323333333"
+ S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEA  EB  TATCFAFCADNT"
+ S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSEC  ED  TBTDFBFDAFNH"
  S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD"
  K V S V="" F I=1,2,3 S V(I)=""
  ;
  ;Next section gets Week 1 and Week 2 data and stores in V(WK)
- F J=1,2 F I=1:1:38,40,42:1:51 S X=+$P(WK(J),"^",I) I X]"" D
- .; Don't report PT/PT for nurses on AWS schedules
- .Q:$E(AC,2)=1&($P(C0,U,16)=72)&(I=32)  ; 36/40 AWS
- .Q:$E(AC,2)=2&($P(C0,U,16)=80)&(I=32)  ; 9month AWS
- .;
+ F J=1,2 F I=1:1:38,40,42,43,44,45,46,47 S X=+$P(WK(J),"^",I) I X]"" D
  .I TYP'["D",I'=38,I'=40 D QH
  .I TYP["D" S X=+X_"0"
Index: FOIAVistA/tag/r/PAID-PRS/PRS8DR.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8DR.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8DR.m	(revision 636)
@@ -1,8 +1,8 @@
-PRS8DR ;HISC/MRL,JAH/WCIOFO-DECOMPOSITION, DRIVER ;4/09/2007
- ;;4.0;PAID;**22,29,56,90,111,112**;Sep 21, 1995;Build 54
+PRS8DR ;HISC/MRL,JAH/WCIOFO-DECOMPOSITION, DRIVER ;1/25/2007
+ ;;4.0;PAID;**22,29,56,90,111**;Sep 21, 1995;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
  ;This routine determines whether or not the parameters necessary
- ;to decompose time are in existence.  The majority of variables
+ ;to decompose time are in existance.  The majority of variables
  ;involving processing an individual employee are defined in this
  ;routine.
@@ -20,17 +20,10 @@
  K WK F I=1,2,3 S WK(I)="" ;weekly totals (wk3=misc data)
  D ^PRSAENT S VAL="" ;get entitlement (ENT)
- I PP="S" G END ;Manila citizen/don't decompose/no stub
+ I PP="S" G END ;manilla citizen/don't decompose/no stub
  I $G(PB)["$" G STUB^PRS8CR ;don't decompose stipend/create stub
- ; Set NAWS to type of AWS
- N NAWS
- S NAWS=0
- I "KM"[$E(AC,1),$E(AC,2)=1,NH=72 S NAWS="36/40 AWS"
- I $E(AC,1)="M",$E(AC,2)=2,NH=80 S NAWS="9Mo AWS"
- ;
  I "^P^X^"[(U_$P($G(^PRST(458,+PY,"E",DFN,0)),"^",2)_U) S RESTORE=1
  D AUTOPINI^PRS8(+PY,+DFN,$G(RESTORE),.PRVAL) ; remove auto-posted data
  S DOUB=0 I $E(ENT,26),$E(ENT,29) S DOUB=1 ;count standby & oncall same
  S FLX="" S FLX=$P($G(^PRST(458,+PY,"E",DFN,0)),"^",6)
- I +NAWS=36 S FLX="C"
  S (SST,TAL)="",X=$P(C0,"^",8) I X'="" D  ;T&L Unit
  .S X=$O(^PRST(455.5,"B",X,0)) ;get ien
@@ -53,7 +46,5 @@
  I $E($G(AC),2)=3 S TYP=TYP_"I" ;intermittent
  I NH>320 S TYP=TYP_"F" I NH'>448 S TYP=TYP_"f" ;firefighter
- ; Nurses on the 9month AWS will be treated as FT employees during the 9 months
- ; that they are working.  Prevent a "P" from being added to TYP.
- I NH,NH'>319,$E(AC,2)'=1 S TYP=TYP_"P" ;part-time
+ I NH,NH'>319 S TYP=TYP_"P" ;part-time
  I PP="L",$E(AC,2)=2 S TYP=TYP_"d" ;doctor
  I PP="L",$E(AC,2)=1 S TYP=TYP_"dR" ;doctor/resident or intern
Index: FOIAVistA/tag/r/PAID-PRS/PRS8EX.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8EX.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8EX.m	(revision 636)
@@ -1,4 +1,4 @@
-PRS8EX ;HISC/MRL,WCIOFO/SAB-DECOMPOSITION, EXCEPTIONS ;1/31/2007
- ;;4.0;PAID;**2,40,56,69,111,112**;Sep 21, 1995;Build 54
+PRS8EX ;HISC/MRL,WCIOFO/SAB-DECOMPOSITION, EXCEPTIONS ;1/25/2007
+ ;;4.0;PAID;**2,40,56,69,111**;Sep 21, 1995;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -27,5 +27,5 @@
  ..Q
  .Q
- S X="^AL^SL^WP^NP^AA^RL^CU^CT^CP^HX^ML^TR^TV^OT^RG^TT^SB^ON^NL^HW^CB^AD^DL^RS" ;code
+ S X="^AL^SL^WP^NP^AA^RL^CU^CT^CP^HX^ML^TR^TV^OT^RG^TT^SB^ON^NL^HW^CB^AD^DL" ;code
  S X=($F(X,"^"_TT)\3)+4,(X,TT(1))=$P($T(ACT+X),";;",2) ;parameters
  S GO=0 I '+X!($E(ENT,+X)) S GO=1 ;entitlement exists-continue
@@ -76,5 +76,5 @@
  I TT'="UN" S VAR=$P(X,"^",3) ;increment time code
  I '$S(VAR'="W":1,'CYA:1,DY<CYA:1,1:0) D
- .S WPCY=1 ;flag to save WOP in hours from 1/1 for calendar year adjustment
+ .S WPCY=1 ;flag to save WOP in hours from 1/1 for calander year adjustment
  I TYP'["D" D  G END ;process hourly people and quit
  .; The following 2 lines commented out because for Employees that are
@@ -144,3 +144,2 @@
  ;;31^Adoption^G^45
  ;;35^Donor Leave^D^46
- ;;5^Recess^r^48
Index: FOIAVistA/tag/r/PAID-PRS/PRS8HD.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8HD.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8HD.m	(revision 636)
@@ -1,4 +1,4 @@
-PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;12/07/2007
- ;;4.0;PAID;**4,33,72,88,94,98,113,118**;Sep 21, 1995;Build 1
+PRS8HD ;HISC/MGD-DECOMPOSITION, DETERMINE HOLIDAYS ;01/3/2007
+ ;;4.0;PAID;**4,33,72,88,94,98,113**;Sep 21, 1995;Build 3
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -160,5 +160,4 @@
  ;;3040611^President Reagan Funeral^FRIDAY^PRS*4*94
  ;;3070102^President Ford Funeral^TUESDAY^PRS*4*113
- ;;3071224^Extra Christmas Day^MONDAY^PRS*4*118
  ;
  ;---------------------------------------------------------------------
Index: FOIAVistA/tag/r/PAID-PRS/PRS8HR.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8HR.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8HR.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8HR ;HISC/MRL,WCIOFO/JAH-DECOMPOSITION, HOURS ;06/25/07
- ;;4.0;PAID;**2,22,29,42,52,102,108,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8HR ;HISC/MRL,WCIOFO/JAH-DECOMPOSITION, HOURS ;05/05/06
+ ;;4.0;PAID;**2,22,29,42,52,102,108**;Sep 21, 1995
  ;
  ;This routine is called by ^PRS8PP (premium pay calculator)
@@ -68,9 +67,11 @@
  I TYP["I",$E(AC,1)="L",TH=320,"4OosEe"[VAL Q
  ;
- ;     IF type of time is anything but Leave Without Pay "W" or Non-Pay "n"
- ;     THEN increment total hrs HT & increment HTP.  Also update
- ;     ^TMP global for reference during the processing of On-Call (PRS8OC).
- ;
- I "Wn"'[VAL S HT=HT+1,HTP=HTP+1,^TMP($J,"PRS8",DAY,"HT")=HT
+ ;     IF type of time is anything but (leave w/out pay, comp time) 
+ ;     THEN increment total hrs(HT) & increment HTP if type of 
+ ;     time not non pay or leave w/out pay.
+ ;
+ ; Update daily counter - *102 added non-pay back into daily count
+ ;
+ S HT=HT+1,HTP=HTP+1
  ;
  ;---------------------------------------------------------
@@ -93,5 +94,5 @@
  ;
  ; Check for FT Compressed
- I $E(AC,2)=1,NH>319,FLX="C",("OoseE4"[VAL) S GO=1
+ I NH>319,FLX="C",("OoseE4"[VAL) S GO=1
  ;
  ; Check for week
@@ -137,5 +138,5 @@
  ;   Check employees with Normal hours less than 80. (Baylor NH=320)
  ;
- I NH'>319!(($E(AC,2)=2)&(NH=320)) D TH^PRS8HRSV D  Q
+ I NH'>319 D TH^PRS8HRSV D  Q
  .I FLX="C" D  Q:X
  ..;
@@ -186,5 +187,24 @@
  .S X=$S("Ee"'[VAL:TOUR+19,(TH(W)'>160)&(HT'>32):9,1:7)
  .I TYP["P",VAL[4,TH(W)'>160,HT'>32 S X=9
- .I TYP["P",VAL="O",TH(W)'>160,HT'>32 S X=9
  .D CHK^PRS8HRSV
  Q
+ ;
+ ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ ; ### DELETE UNLESS EARLIER CHECK WAS RESTORED
+CT2DAY() ;Determine if comptime eligible including 2 day tour.
+ ;
+ N TOUREC,TWODAY
+ S (RTN,TWODAY)=0
+ ;
+ ;      IF time segment contains Scheduled or unscheduled comptime 
+ ;      or overtime and there is some time in tour hours worked THEN
+ ;      check if it's a 2 day tour. For 2 day tours some of time worked
+ ;      won't be in HT variable since it occured on other day of two
+ ;      day tour, it's not valid to simply check the HT variable for
+ ;      8 hours of work. (patch PRS*4*22)
+ ;
+ I "OosEe4"[VAL,(HT>0),(NH>319) D
+ .S TOUREC=$P($G(DAY(DAY,0)),"^",2)
+ .I TOUREC>0 S TWODAY=$P($G(^PRST(457.1,TOUREC,0)),"^",5)
+ .I TWODAY="Y" S RTN=1
+ Q RTN
Index: FOIAVistA/tag/r/PAID-PRS/PRS8HRSV.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8HRSV.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8HRSV.m	(revision 636)
@@ -1,8 +1,7 @@
-PRS8HRSV ;WCIOFO/JAH-HOLIDAY FLAG, TIME CHECKER, WK() SET; 04/05/07
- ;;4.0;PAID;**29,52,102,108,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;  Set up variable for holiday worked or holiday excused
+PRS8HRSV ;WCIOFO/JAH-HOLIDAY FLAG, TIME CHECKER, WK() SET; 05/02/06
+ ;;4.0;PAID;**29,52,102,108**;Sep 21, 1995
+ ;  Set up variable for holiday worked or holiday exused
  ;  Holiday worked coded 2 in DAY array
- ;  Holiday excused coded 1 in DAY array
+ ;  Holiday exused coded 1 in DAY array
  ;  A NON holiday is coded as all zero's in day array.
  ;
@@ -61,12 +60,4 @@
  I X,Y=2,$E(ENT,+Y)'="H" S X=$S(TYP'["B":0,1:9)
  ;
- ;   IF 36/40 AWS with WP determine eligibility for OT/CT
- ;   Skip this check if time is HW (X=29) or OT on Hol (X=24)
- ;   
- I "KM"[$E(AC,1),$E(AC,2)=1,$P(C0,U,16)=72,X'=32,X'=29,X'=24 D
- . I HT>32 S X=$S(VAL="O":TOUR+15,VAL="e":7,1:X)  Q
- . I TH(W)>160 S X=$S(VAL="O":TOUR+19,VAL="e":7,1:X)  Q
- . I HT'>32,TH(W)'>160 S X=9
- ;
  ;   If X is hours in excess of 8/day & > 40/week & type of time
  ;   is compensatory time X = 0
@@ -112,8 +103,4 @@
  ..I X'=32,$E(ENT,25),'HOLWKD D
  ...S ZZ=X
- ...; for 36/40 AWS w/ WP or NP report OT on Holiday as (OK/OS)
- ...; For 9mo AWS w/ Recess report OT on Holiday as (OK/OS)
- ...I +NAWS,VAL["O",$E(DAY(DAY,"HOL"),M)=0 S X=24 D SET S X=0 Q
- ...;
  ...S X=$S(TYP["P"!(TYP["I"):TOUR+28,1:24) D SET
  ...I TYP["P"!(TYP["I") S X=9 D SET
@@ -167,11 +154,4 @@
 SET ; --- Set value into WK array
  ;
- ; Nurses on the 36/40 AWS are FT with Normal Hours of 72.  Nurses on the 9 month
- ; AWS are PT with Normal Hours of 80.  Neither will not have Part Time Hours
- ; counted in their 8B string.
- ;
- Q:$E(AC,2)=1&($P(C0,U,16)=72)&(X=32)  ; 36/40 AWS
- Q:$E(AC,2)=2&(NH=320)&(X=32)  ; 9month AWS before any Recess processed
- ;
  ;     Full time employee & part time hours & normal hours WK1 + WK2
  ;     = biweekly normal hours.
@@ -198,5 +178,4 @@
  I $S(VAL=4:1,"osEe"[VAL!(VAL="O"&('HOLWKD)):1,1:0) D
  . Q:(HT>32)&(TH(W)<160)&(NH<320)&($E(ENT,19)=1)
- . Q:(HT>32)&(TH(W)<160)&(NH=320)&($E(ENT,19)=1)&($E(AC,2)=2)  ; 9month AWS
  . S TH=TH+1,TH(W)=TH(W)+1
  Q
Index: FOIAVistA/tag/r/PAID-PRS/PRS8MSC0.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8MSC0.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8MSC0.m	(revision 636)
@@ -1,4 +1,4 @@
-PRS8MSC0 ;HISC/DAD,WCIOFO/JAH,SAB - MISC TIME CARD ADJUST(contd) ;4/04/2007
- ;;4.0;PAID;**22,35,40,56,111,112**;Sep 21, 1995;Build 54
+PRS8MSC0 ;HISC/DAD,WCIOFO/JAH,SAB - MISC TIME CARD ADJUST(contd) ;1/25/2007
+ ;;4.0;PAID;**22,35,40,56,111**;Sep 21, 1995;Build 2
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -80,18 +80,9 @@
  ...I TYP["W",$E($P(PEROT(H),"^",3))'="E"&($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF"))=0) S TOUR=$G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"TOUR"))
  ...S D=+OT,P=$S($E($P(PEROT(H),"^",3))'="E":TOUR+19,1:7),Y=8-(STOP-START+1+Z)
- ...;
- ...I TYP["P",TYP'["B",P'=7,'+NAWS D
+ ...I TYP["P",TYP'["B",P'=7 D
  ....I $P($G(^TMP($J,"PRS8",$P(PEROT(H),"^",1),"OFF")),"^",1)=1&(TH(WEEK)'>160) S Y=0 Q
  ....I $P(C0,"^",12)="E" S P=$S($L($TR(W,"0O"))>31&(TH(WEEK)'>160):TOUR+25,1:P) D:Y SET S Y=$S(TH(WEEK)'>160:Y,1:0) S P=9 D:Y SET S Y=0
  ...I $P(C0,"^",12)="N",P'=7 S P=$S($L($TR(W,"0O"))>31:TOUR+15,1:P) D:Y SET S Y=0
- ...D:Y&('+NAWS) SET
- ...;
- ...I +NAWS D  Q  ; Checks for just the AWS nurses
- ....N CNT,HT,I
- ....S CNT=Y,Y=1,HT=$G(^TMP($J,"PRS8",D,"HT"))
- ....F I=1:1:CNT D
- .....I HT'<32 S P=$S(P'=7:TOUR+15,1:P) D SET1 Q  ; DA/DE or CE/CT
- .....I TH($S(+OT>7:2,1:1))'<160 S P=$S(P'=7:TOUR+19,1:P) D SET1 Q  ; OA/OE or CE/CT
- .....I HT<32,TH($S(+OT>7:2,1:1))<160 S P=9 D SET1 Q  ; UN/US
+ ...D:Y SET
  ..Q
  .Q
@@ -109,15 +100,4 @@
  S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y
  Q
- ;
-SET1     ; Set sleep time into WK array
- Q:D<1!(D>14)
- S WEEK=$S(D>7:2,1:1)
- S $P(WK(WEEK),"^",P)=$P(WK(WEEK),"^",P)+Y
- Q:(HT>32)&(TH(WEEK)<160)&(NH<320)&($E(ENT,19)=1)
- Q:(HT>32)&(TH(WEEK)<160)&(NH=320)&($E(ENT,19)=1)&($E(AC,2)=2)  ; 9month AWS
- S HT=HT+1,TH(WEEK)=TH(WEEK)+1
- S ^TMP($J,"PRS8",D,"HT")=^TMP($J,"PRS8",D,"HT")+1
- Q
- ;
 OTNXTPP(DAY,CALLBK,EMPNM,PPIEN,TLU) ;
  ;OT or CT connects to a tour of duty in the next pay period.
@@ -176,7 +156,5 @@
  F W=1,2 D  ;              For each week subtract leave ND from total ND
  . Q:'WKL(W)  ;                                 No leave ND to subtract
- . I +NAWS'=36 S $P(WK(W),"^",10)=$P(WK(W),"^",10)-WKL(W) ; Subtract
- . ; For 36/40 AWS subtract time from Night Differential-AWS (piece 51)
- . I +NAWS=36 S $P(WK(W),"^",51)=$P(WK(W),"^",51)-WKL(W)
+ . S $P(WK(W),"^",10)=$P(WK(W),"^",10)-WKL(W) ; Subtract
  . S WKL(W)=0 ;                                 Reset leave ND amount
  Q
Index: FOIAVistA/tag/r/PAID-PRS/PRS8MT.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8MT.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8MT.m	(revision 636)
@@ -1,4 +1,4 @@
-PRS8MT ;HISC/MRL-DECOMPOSITION, MEALTIME ;02/21/08
- ;;4.0;PAID;**2,40,69,102,109,112,116**;Sep 21, 1995;Build 23
+PRS8MT ;HISC/MRL-DECOMPOSITION, MEALTIME ;11/22/06
+ ;;4.0;PAID;**2,40,69,102,109**;Sep 21, 1995;Build 5
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -32,8 +32,4 @@
 GETY ; --- this is where Y (placement of mealtime) is defined
  S X=$E(D,V(1),V(2)),D1=$E(D1,V(1),V(2))
- N ORIGX,RECESS
- S ORIGX=X ; Original copy of codes in X and
- S RECESS=DAY(MDY,"r")_$G(DAY(MDY,"rN"))
- S RECESS=$E(RECESS,V(1),V(2)) ; load any Recess
  I X["5" D
  . N DAYP
@@ -48,17 +44,13 @@
  .S Y=$E(X,M)
  .I "1235C"[Y,"1235C"[X1 Q  ; scheduled work time
- .I "4OC"[Y,$E(RECESS,M)="r" S Q=0 Q  ; Work performed while on Recess (9mo AWS)
  .I Y'="O",Y'=X1 S Q=0 Q  ; not same type of time, and non-OT
- .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))'=2) S Q=0 Q  ; OT indicating non-holiday worked gets no meal
- .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))=2),"123C"[X1 S Q=0 Q  ; OT indicating holiday worked and Excused.
+ .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))'=2) S Q=0 Q  ; OT indicatin' non-holiday worked gets no meal
+ .I Y="O",($E(DAY($S(V(1)+M-1<97:MDY,1:MDY+1),"HOL"),$S(V(1)+M-1<97:V(1)+M-1,1:V(1)+M-1-96))=2),"123C"[X1 S Q=0 Q  ; OT indicatin holiday worked and Excused.
  .Q
  I X["0" D
- .I RECESS'["r" S SPL=$TR(X,"1235"),SPLX=$TR(X,SPL,$TR($J("",$L(SPL))," "))
- .I RECESS["r" S SPL=$TR(X,"01235"),SPLX=$TR(X,SPL,$TR($J("",$L(SPL))," "))
+ .S SPL=$TR(X,"1235"),SPLX=$TR(X,SPL,$TR($J("",$L(SPL))," "))
  .I SPLX="" S Q=1
- ;
- K M
- ;--- one activity for entire tour
- I Q S Q=0 D  F M=1:1:MT S M(M)=Y+M-1
+ ; --- one activity for entire tour
+ K M I Q S Q=0 D  F M=1:1:MT S M(M)=Y+M-1
  .I V(1)>24,V(2)<73 S Y=MID Q  ;no premium time involved/ meal in middle
  .S Q=0 D  ;check for all premium
@@ -78,65 +70,34 @@
  ; --- multiple activities per tour
  E  D
- .S Z=$TR(X,"1235"),X=$TR(X,Z,$TR($J("",$L(Z))," ","0"))
- .;
- .; if leave posted > or = to tour length + mt (ie didn't post around 
- .; lunch) it was resulting in OT (ZRIK strips HOL, OC, & no tour time)
- .;
- .S ZRIK=$TR(Z,"HC0")
- .I MT>0,$L(ZRIK)'<(($P(DAY(DAY,0),"^",8)*4)+MT) S X="",$P(X,"1",$L(ZRIK)+1)=""
- .Q:X?1"0"."0"&(RECESS'["r")
- .S M=0 F A=1,2 Q:M=MT  F B=MID,MID+1,MID-1:-1:V(1),MID+2:1:V(2) D  Q:M=MT
- ..Q:'$E(X,B-V(1)+1)
- ..I A=1,PM,B<25!(B>72&(B<121)) S M=M+1,M(M)=B
- ..I A=1,'PM,B>24&(B<73)!(B>120) S M=M+1,M(M)=B
- ..I A=2 S M=M+1,M(M)=B
- ..Q
- .Q
+ .  S Z=$TR(X,"1235"),X=$TR(X,Z,$TR($J("",$L(Z))," ","0"))
+ .  S ZRIK=$TR(Z,"HC") I MT>0,$L(ZRIK)'<(($P(DAY(DAY,0),"^",8)*4)+MT) S X="",$P(X,"1",$L(ZRIK)+1)="" ;if leave posted > or = to tour length + mt (ie didn't post around lunch) it was resulting in OT (ZRIK strips HOL & OC)
+ .  Q:X?1"0"."0"
+ .  S M=0 F A=1,2 Q:M=MT  F B=MID,MID+1,MID-1:-1:V(1),MID+2:1:V(2) D  Q:M=MT
+ .  .  Q:'$E(X,B-V(1)+1)
+ .  .  I A=1,PM,B<25!(B>72&(B<121)) S M=M+1,M(M)=B
+ .  .  I A=1,'PM,B>24&(B<73)!(B>120) S M=M+1,M(M)=B
+ .  .  I A=2 S M=M+1,M(M)=B
+ .  .  Q
+ .  Q
  Q:'$O(M(0))
 Y ; --- this is where meals get placed in string
  F Y=0:0 S Y=$O(M(Y)) Q:Y'>0  D
  . N ORIGAC ; original activity code
- . S M=M(Y),(X,ORIGAC)=$E(D,M),X=$S(X="J":"A",X=5:$E(DAY(MDY,"P"),M),1:X)
- . ; If a 9mo AWS works during Recess don't place meal over that type of time
- . I +NAWS=9 D  ; 9mo AWS nurses
- . . ; If extra work (UN,OT,CT) was posted over the entire tour including the meal time
- . . ; don't include meal time in the W node or you will reduce the extra work count.
- . . ; Set X=0 to reduce the Recess count below.
- . . I "4OEC"[ORIGAC&($L(ORIGX)=$L($TR(ORIGX,"1235"))) S X=0 Q
- . . ;
- . . ; If extra work posted over tour time that wasn't covered by Recess it will
- . . ; be stored in the r node.  If this time exists, add that time back into the 
- . . ; W node instead of the meal time.
- . . I "1235"[ORIGAC,"4OEC"[$E(RECESS,M-V(1)+1) D  Q
- . . . S D=$E(D,0,M-1)_$E(RECESS,M-V(1)+1)_$E(D,M+1,999)
- . . . S ORIGX=$E(ORIGX,1,M-V(1)-1)_$E(RECESS,M-V(1)+1)_$E(ORIGX,M-V(1)+2,999)
- . . ;
- . . ; For everything else, update D and ORIGX
- . . S D=$E(D,0,M-1)_"m"_$E(D,M+1,999)
- . . S ORIGX=$E(ORIGX,M-V(1)-1)_"m"_$E(ORIGX,M-V(1)+2,999)
- . ;
- . ; All employees other than 9mo AWS
- . I +NAWS'=9 S D=$E(D,0,M-1)_"m"_$E(D,M+1,999)
- . ;
- . ; The following line has been updated to include a check for Recess as the 48th piece.
- . ; Recess will be designated as a zero (0). 
- . S X=$S(X'="M":$F("LSWnAR*U************************V********YXFGD*0",X)-1,1:5)
- . ;
- . ; Firefighter checks
- . I "Ff"[TYP,NH'=480!(NH(1)'=NH(2)) S X=32
- . ;I X'=4,CYA2806>0 S CYA2806=CYA2806-1 ; << ADDED-> DROP LUNCH FROM CY ALSO>>
- . Q:X'>0
- . Q:MDY=0&(M(Y)<96)!(MDY=14&(M(Y)>97))
- . S W=$S(MDY<8:1,1:2) I MDY=7&(M(Y)>96) S W=2
- . I $P(WK(W),"^",+X)>0 S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)-1 ;subtract
- . ;
- . ; If Military Leave subtract the mealtime out of the WK(3) array.
- . I ORIGAC="M",$P(WK(3),U,11)>0 S $P(WK(3),U,11)=$P(WK(3),U,11)-1
- . ;I WPCYA>0 S WPCYA=WPCYA-1 ;lunch from total << AND FROM CA TOTAL >>
+ .  S M=M(Y),(X,ORIGAC)=$E(D,M),X=$S(X="J":"A",X=5:$E(DAY(MDY,"P"),M),1:X),D=$E(D,0,M-1)_"m"_$E(D,M+1,999)
+ .  S X=$S(X'="M":$F("LSWnAR*U************************V********YXFGD",X)-1,1:5)
+ .  I "Ff"[TYP,NH'=480!(NH(1)'=NH(2)) S X=32
+ .  ;I X'=4,CYA2806>0 S CYA2806=CYA2806-1 ; << ADDED-> DROP LUNCH FROM CY ALSO>>
+ .  Q:X'>0
+ .  Q:MDY=0&(M(Y)<96)!(MDY=14&(M(Y)>97))
+ .  S W=$S(MDY<8:1,1:2) I MDY=7&(M(Y)>96) S W=2
+ .  I $P(WK(W),"^",+X)>0 S $P(WK(W),"^",+X)=$P(WK(W),"^",+X)-1 ;subtract
+ .  ; If Military Leave subtract the mealtime out of the WK(3) array.
+ .  I ORIGAC="M",$P(WK(3),U,11)>0 S $P(WK(3),U,11)=$P(WK(3),U,11)-1
+ .  ;I WPCYA>0 S WPCYA=WPCYA-1 ;lunch from total << AND FROM CA TOTAL >>
  . ; PRS*4*40 added 8 (U), 44 (F), 45 (G), 46 (D) to following line
  . ; because PRS8AC also increments LU for those types of time
- . I +X,"^1^2^6^8^44^45^46^"[("^"_+X_"^") S LU=LU-1 ;reduce leave used
- . I +X,"^3^"[("^"_+X_"^"),"P"[TYP S TH=TH+1,TH(W)=TH(W)+1
- . Q
+ .  I +X,"^1^2^6^8^44^45^46^"[("^"_+X_"^") S LU=LU-1 ;reduce leave used
+ .  I +X,"^3^"[("^"_+X_"^"),"P"[TYP S TH=TH+1,TH(W)=TH(W)+1
+ .   Q
  S DAY(MDY,"W")=$E(D,1,96)
  S X=$E(D,97,999) I $L(X) D
Index: FOIAVistA/tag/r/PAID-PRS/PRS8OC.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8OC.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8OC.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8OC ;HISC/MGD-DECOMPOSITION, ON-CALL ;02/27/07
- ;;4.0;PAID;**63,92,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8OC ;HISC/MGD-DECOMPOSITION, ON-CALL ;02/17/04
+ ;;4.0;PAID;**63,92**;Sep 21, 1995         
  ;
  ;The following MUMPS code is used to credit the appropriate
@@ -34,7 +33,5 @@
 OCS ; --- set On-Call minimum hours
  ;set YA/YE for PPI="W" or "V" else set OT
- I +NAWS=0 S Y=$S(CC:7,'DOUB:TOUR+19,1:23)
- I +NAWS S Y=$S(CC:7,1:TOUR+19)
- ;
+ S Y=$S(CC:7,'DOUB:TOUR+19,1:23)
  N X,Z,DD,TT,CCCNT,NEXTT,OCCNT,TIMECNT
  S TT=$S(T>96:T-96,1:T),TIMECNT=0
@@ -83,6 +80,5 @@
  ..I OC+CNTR'>8 D
  ...S Y(1)=$S(X=1:OC,1:8-CNTR)
- ...I +NAWS=0 D CHOL ; Process everyone but AWS nurses
- ...I +NAWS D CHOL1 ; Process AWS nurses
+ ...D CHOL
  ...S (OC,OC(D),CC,CC(D))=0,FG=1
  ..Q
@@ -98,6 +94,5 @@
  ..I OC+CNTR'>8 D
  ...S Y(1)=$S(X=1:OC,1:8-CNTR)
- ...I +NAWS=0 D CHOL ; Process everyone but AWS nurses
- ...I +NAWS D CHOL1 ; Process AWS nurses
+ ...D CHOL
  ...S (OC,OC(D),CC,CC(D))=0,FG=1
  ..Q
@@ -118,10 +113,8 @@
  ...;
  ..S Y(1)=$S(X=2:CC(I)+CCCNT,X:CC(I),OC(I)>7:CC(I),1:4),Y=7
- ..I +NAWS=0 D CHOL ; Process everyone but AWS nurses
- ..I +NAWS D CHOL1 ; Process AWS nurses
+ ..D CHOL
  ..S Y(1)=$S(X=2:OC(I)-CC(I)+OCCNT,X:OC(I)-CC(I),OC(I)>7:OC(I)-CC(I),1:4)
  ..S Y=$S('DOUB:TOUR+19,1:23)
- ..I +NAWS=0 D CHOL ; Process everyone but AWS nurses
- ..I +NAWS D CHOL1 ; Process AWS nurses
+ ..D CHOL
  ..Q
  .Q
@@ -132,6 +125,5 @@
  ...I T=96,"ct"'[$E(DAY(DAY+1,"W"),1) S OC(I)=8-TIMECNT
  ..S Y(1)=$S(X:OC(I),OC(I)>7:OC(I),1:8)
- ..I +NAWS=0 D CHOL ; Process everyone but AWS nurses
- ..I +NAWS D CHOL1 ; Process AWS nurses
+ ..D CHOL
  ..Q
  .Q
@@ -155,31 +147,2 @@
  E  S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+Y(1)
  Q
- ;
-CHOL1 ; Checks for AWS nurses
- N HT,J,K,T2ADD
- S K=0,TMP=Y,Y=0
- S T2ADD=$S(CC:Y(1)-CC,1:Y(1)-OC-CC)
- ; Apply normal checks for OT on Hol and Hol Callback
- I TMP'=7,$E(ENT,25),$$HOLIDAY^PRS8UT(PY,DFN,+D) S Y=24 ;ot on actual hol
- I 'Y,$E($G(DAY(I,"HOL")),$S(T>96:(T-96),1:T)) S Y=TOUR+28 ;holiday callback
- I 'Y S Y=TMP
- I Y=24!(Y=(TOUR+28)) D SET Q
- ; If not OT on Hol or Hol Callback Determine if we are setting OT or CT
- S K=$S(Y=7:CC,1:OC)
- F J=1:1:K D AWSWK ; Update actual time worked
- F J=1:1:T2ADD D AWSWK ; Update time added to reach 2 hour min
- Q
- ;
-AWSWK ; Determine what type of time to add based on 8/day and 40/wk
- S HT=+$G(^TMP($J,"PRS8",D,"HT"))
- I HT'<32 S Y=$S(Y'=7:TOUR+15,1:Y) D SET1 Q
- I TH(W)'<160 S Y=$S(Y'=7:TOUR+19,1:Y) D SET1 Q
- I HT<32,TH(W)<160 S Y=9 D SET1
- Q
- ;
-SET1 ; Set WK array for AWS nurses
- S $P(WK(W),"^",Y)=$P(WK(W),"^",Y)+1
- Q:HT'<32
- S TH=TH+1,TH(WK)=TH(WK)+1
- S ^TMP($J,"PRS8",DAY,"HT")=HT+1
- Q
Index: FOIAVistA/tag/r/PAID-PRS/PRS8PP.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8PP.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8PP.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8PP ;HISC/MRL,WIRMFO/MGD-DECOMP, PREMIUM PAYS ;05/10/07
- ;;4.0;PAID;**22,40,75,92,96,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8PP ;HISC/MRL,WIRMFO/MGD-DECOMP, PREMIUM PAYS ;02/27/04
+ ;;4.0;PAID;**22,40,75,92,96**;Sep 21, 1995
  ;
  ;This routine is the entry point for determining certain premium
@@ -98,25 +97,12 @@
  . . S DAT=$G(^TMP($J,"PRS8",DAYN,2)) D  Q:FND
  . . . ; loop thru tour segments in exceptions
- . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*4+1)=""  D  Q:FND
+ . . . F TS=1:1:7 Q:$P(DAT,U,(TS-1)*3+1)=""  D  Q:FND
  . . . . ; check if time contained in exception segment
- . . . . I M1'<$P(DAT,U,(TS-1)*4+1),M1'>$P(DAT,U,(TS-1)*4+2) D
- . . . . . S TOT=$P(DAT,U,(TS-1)*4+3)
- . . . . . ; On-Call and Recess are the only types of exceptions
- . . . . . ; where OT, CT and RG can be posted for the same 15 minute
- . . . . . ; segment of time, so don't stop searching if you find these.
- . . . . . I TOT="ON"!(TOT="RS") S TOT="" Q
- . . . . . S FND=1,SC=$P(DAT,U,(TS-1)*4+4)
- . . . . . Q
- . Q:TOT="OT"&("^11^12^17^"'[(U_SC_U))  ; Pre-Scheduled & Tour Coverage & OT/CT With Premiums
- . Q:TOT="CT"&("^12^17^"'[(U_SC_U))     ; Tour Coverage & OT/CT With Premiums
- . ; Code 17 - OT/CT with premiums only get ND for 6p-6a
- . Q:TOT="OT"!(TOT="CT")!(TOT="RG")&(SC=17)&((M'<25)&(M'>72))
- . Q:TOT="RG"&(SC'=7)&(SC'=17)          ; Shift Coverage & OT/CT With Premiums
- . S X=10
- . ; for 36/40 AWS, premium time resulting from their tour 
- . ; will be mapped to Night Differential-AWS (ND/NU) and
- . ; Paid at the AAC with the 1872 divisor for the hourly rate (36*52)
- . I +NAWS=36,("OEc"'[VAL!(TOT="HW")) S X=51
- . D SET
+ . . . . I M1'<$P(DAT,U,(TS-1)*3+1),M1'>$P(DAT,U,(TS-1)*3+2) D
+ . . . . . S FND=1,TOT=$P(DAT,U,(TS-1)*3+3),SC=$P(DAT,U,(TS-1)*3+4)
+ . Q:TOT="OT"&("^11^12^"'[(U_SC_U))  ; Pre-Scheduled & Tour Coverage
+ . Q:TOT="CT"&(SC'=12)               ; Tour Coverage
+ . Q:TOT="RG"&(SC'=7)                ; Shift Coverage
+ . S X=10 D SET
  . ; keep leave count since it may need to be backed out by PRS8MSC0
  . I "LSRUFGD"[VAL S WKL(WK)=WKL(WK)+1
@@ -157,13 +143,5 @@
  . . ; grant ND (unless meal-time, etc.), keep count of leave since it
  . . ;   may need to be backed out by PRS8MSC0
- . . I AV[$E(D,J) D
- . . . S X=10
- . . . ; For 36/46 AWS nurses ND for Holiday Worked (HA/HL) and normal
- . . . ; tour time will be reported as Night Differential-AWS (ND/NU)
- . . . I +NAWS=36 D
- . . . . I $E(DAY(DAY,"HOL"),J)=2 S X=51 Q  ; Holiday Worked
- . . . . I "OEc"'[VAL S X=51 ; Tour time
- . . . D SET
- . . . S:"LSRUFGD"[$E(D,J) WKL(WK)=WKL(WK)+1
+ . . I AV[$E(D,J) S X=10 D SET S:"LSRUFGD"[$E(D,J) WKL(WK)=WKL(WK)+1
  ;
  Q
Index: FOIAVistA/tag/r/PAID-PRS/PRS8ST.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8ST.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8ST.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8ST ;HISC/MGD-DECOMPOSITION, START-UP ;05/09/07
- ;;4.0;PAID;**45,92,102,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8ST ;HISC/MGD-DECOMPOSITION, START-UP ;12/12/05
+ ;;4.0;PAID;**45,92,102**;Sep 21, 1995
  ;
  ;This routine is the one which actually gets everything moving.
@@ -15,5 +14,5 @@
  .S LP=$S(DAY=1:"0,1,2",1:(DAY+1)),JURY=0
  .F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
- ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","r" D
+ ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W" D
  ...S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J))
  ...;
@@ -26,11 +25,9 @@
  ..S WK=$S(DY<8:1,1:2)
  ..S TOUR=$S(TYP'["W":1,+DAY(DY,"TOUR"):+DAY(DY,"TOUR"),1:+TOUR(WK))
- ..D MOVE^PRS8AC
- ..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
+ ..D MOVE^PRS8AC S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
  ..I N["UN" S X1="UN" D 2 ;unavailable
  ..I N["HX" S X1="HX" D 2 ;holiday excused
  ..I N["ON" S X1="ON" D 2 ;on-call
  ..I N["SB" S X1="SB" D 2 ;standby
- ..; Process the scheduled tours
  ..S N=DAY(DY,1),DH=DAY(DY,"DH1"),NN=1 D  I DAY(DY,"TWO") S N=DAY(DY,4),DH=DAY(DY,"DH2"),NN=4 D
  ...S QT=0 F PRS8=1:3 S V=$P(N,"^",PRS8,PRS8+2) Q:QT  D
@@ -51,31 +48,12 @@
  .....F J=4,8,12,16,20,24,28 S:$P(JURY,"^",J)=6 JURY=1 Q
  ....D ^PRS8AC ;build "W" node
- ..; Process the exceptions
  ..S N=DAY(DY,2),WK=$S(DY<8:1,1:2) ;exception node/week
- ..S QT=0
- ..; If there are Recess exceptions, process them first
- ..I N["RS" D
- ...; Since Recess will reduce hours worked in the week add P to TYP
- ...I TYP'["P" S TYP=TYP_"P"
- ...F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT  D
- ....Q:$P(V,"^",3)='"RS"
- ....I TYP["D",$P(V,"^",3)="" S QT=1 Q  ;doctor
- ....I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q  ;all others
- ....S X=$P(V,"^",3)
- ....I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX
- ...;
- ...; Process all other types of exceptions
- ..S QT=0
- ..F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT  D
- ...Q:$P(V,"^",3)="RS"
+ ..S QT=0 F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+3) Q:QT  D
  ...I TYP["D",$P(V,"^",3)="" S QT=1 Q  ;doctor
  ...I TYP'["D",'+V,$P(V,"^",3)="" S QT=1 Q  ;all others
- ...S X=$P(V,"^",3)
- ...I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX
- ..;
+ ...S X=$P(V,"^",3) I "^UN^ON^SB^HX^"'[("^"_X_"^") D ^PRS8EX
  ..S ^TMP($J,"PRS8",DY,"W")=DAY(DY,"W") ;save in ^TMP
  ..S ^TMP($J,"PRS8",DY,"P")=DAY(DY,"P") ;save non-prem ot in ^TMP
  ..S ^TMP($J,"PRS8",DY,"HOL")=DAY(DY,"HOL") ;holiday
- ..S ^TMP($J,"PRS8",DY,"r")=DAY(DY,"r") ; Recess for 9mo AWS nurse
  .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off
  .S TOUR=$S(TYP'["W":1,+DAY(DAY,"TOUR"):+DAY(DAY,"TOUR"),1:+TOUR(WK))
@@ -86,17 +64,10 @@
  .Q
  ;
- ;make DAY array available for prior, current, and next day
  F DAY=1:1:14 D
- .; I AWS Nurse check to see if hour counts need to be adjusted
- .S WK=$S(DAY<8:1,1:2)
- .; For each week, TYP should not contain "P" unless:
- .; 36/40 AWS has NP or WP
- .;   9mo AWS has Recess
- .I +NAWS,(DAY=1!(DAY=8)) S TYP=$TR(TYP,"P","") D NAWS
- .;
+ .;make DAY array available for prior, current, and next day
  .K DAY(DAY-2)
  .S LP=$S(DAY=1:"0,1,2",1:(DAY+1))
  .F II=1:1 S DY=$P(LP,",",II) Q:DY=""  D
- ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","F","r" S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J))
+ ..F J=0,1,2,4,10,"CP","DH1","DH2","HOL","ML","MT1","MT2","OFF","P","TOUR","TWO","W","F" S DAY(DY,J)=$G(^TMP($J,"PRS8",DY,J))
  .;
  .S WK=$S(DAY<8:1,1:2),OFF=+DAY(DAY,"OFF") ;week/day off
@@ -104,5 +75,5 @@
  .;
  .I ((TYP["I")!(TYP["P")),DAY>0,DAY<15 D  ;FOR CY
- ..I $S('CYA:1,DAY<CYA:1,1:0) Q  ;quit if no calendar year adjustment
+ ..I $S('CYA:1,DAY<CYA:1,1:0) Q  ;quit if no calander year adjustment
  ..S IIX=0 I $E(ENT,2)'="D" F II=1:1:$L(DAY(DAY,"W")) D
  ...I "4E"[$E(DAY(DAY,"W"),II) S IIX=IIX+1
@@ -119,5 +90,5 @@
  ...I T=96!("BbCct"'[$E(DAY(DAY,"W"),T+1)) S OK=T
  ...I DOUB D ^PRS8OC,^PRS8SB Q  ;Prem. Pay of "W" or "V"
- ...I VAR1'=""&("Cct"[VAR1) D ^PRS8OC Q  ;compute on-call/2hr minimum
+ ...I VAR1'=""&("Cct"[VAR1) D ^PRS8OC Q  ;compte on-call/2hr minimum
  ...I "Bb"[VAR1 D ^PRS8SB ;standby
  .I $G(SBY) D UP^PRS8SB
@@ -141,5 +112,5 @@
  I '$E(ENT,$P("12^28^^29^26^^^29","^",+X)) S Q=1 ;entitlement string
  ;PATCH 45: ADD CHECK FOR FIRE FIGHTER ADDITIONAL HOURS
- ;SINCE THIS TYPE OF TIME IS NOT IN THE ENTITLEMENT TABLE
+ ;SINCE THIS TYPE OF TIME IS NOT IN THE ENTITLMENT TABLE
  ;IT IS SET UP WITH TOUR IND. WITH CODE 9
  I "Ff"[TYP,X=9 S Q=0
@@ -150,29 +121,3 @@
  F PRS8=1:4:25 S V=$P(N,"^",PRS8,PRS8+2) Q:$P(V,"^",1)=""  D
  .S X=$P(V,"^",3) I X=X1 D ^PRS8EX
- K PRS8,X,V
- Q
- ;
-NAWS ; NAWS Nurse Alternate Work Schedules
- ; If any NP or WP has been incurred for a nurse on the 36/40 AWS,
- ; adjust their hours worked counts.  40 hrs/wk will now be used to 
- ; determine their qualification for OT and CT.  Check piece 16 of
- ; 0 node as NH will have been updated to 320 in PRS8SU.
- ;
- I +NAWS=36 D
- .Q:$P(WK(WK),U,3)=""&($P(WK(WK),U,4)="")
- .S TH(WK)=144-($P(WK(WK),U,3)+$P(WK(WK),U,4)) ; Adjust Total Hours per week
- .S TH=TH(1)+TH(2) ; Adjust Total Hours per pay period
- .S NH(WK)=144,NH=288 ; Adjust Normal Hours
- .I TYP'["P" S TYP=TYP_"P" ; Make them into a PT employee
- .S $E(ENT,2)=1 ; Make employee eligible for UN/US
- ;
- ; If any Recess has occurred for a nurse on the 9month AWS, adjust 
- ; their hours worked counts.  These employees will be treated as PT
- ; in determining the eligibility for OT/CT.
- ;
- I +NAWS=9 D
- .Q:$P(WK(WK),U,48)=""
- .S TH(WK)=TH(WK)-$P(WK(WK),U,48) ; Adjust total hours per week
- .S TH=TH(1)+TH(2) ; Adjust Total Hours
- .I TYP'["P" S TYP=TYP_"P" ; Adjust TYP to represent a PT employee
- Q
+ K PRS8,X,V Q
Index: FOIAVistA/tag/r/PAID-PRS/PRS8SU.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8SU.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8SU.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8SU ;HISC/MRL-DECOMPOSITION, SET-UP ;02/20/08
- ;;4.0;PAID;**112,116**;Sep 21, 1995;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8SU ;HISC/MRL-DECOMPOSITION, SET-UP ;7/15/93  10:40
+ ;;4.0;PAID;;Sep 21, 1995
  ;
  ;This routine sets up various data elements required to process
@@ -8,5 +7,5 @@
  ;holiday information, etc.  All times are converted to 15-minute
  ;increments in this routine (the number of 15-minute increments
- ;into the day).  Additionally, the credit tour for WG
+ ;into the day).  Additionally, the credity tour for WG
  ;employees is determined in this routine.
  ;
@@ -36,5 +35,5 @@
  ....S FLAG=1 I N=2&(K1=1)&("^HW^"[("^"_$P(Z,"^",K+2)_"^")) S FLAG=$S(NDAY=1!(LAST>96)&("^HW^"[("^"_$P(Z,"^",K+2)_"^"))&((X["A")!(X["MID")):0,1:1),NDAY=0
  ....S:$P(D(0),"^",14)'=""&(X="MID")&(LAST=96)&(N=2)&(K1=1) FLAG=0 S:N=2&(K1=1)&(FLAG=1) (NDAY,LAST)=0 S Y=K1-1 D 15
- ....I N=2,"^RG^OT^CT^ON^SB^"'[("^"_$P(Z,"^",K+2)_"^") D
+ ....I N=2,"^RG^OT^CT^ON^SB^HW^"'[("^"_$P(Z,"^",K+2)_"^") D
  .....S Y=+$O(DADRFM("S",(-X-.01))),Y1=+$O(DADRFM("F",(X-.01)))
  .....I $G(DADRFM("S",Y))'=$G(DADRFM("F",Y1)) S X=X+96
@@ -63,5 +62,4 @@
  .S X="HOL" D SET ;save holiday string
  .S X="P" D SET ;premium node
- .S X="r" D SET ;Recess node
  .S X=D(0),OFF=0 I $P(X,"^",2)=1 S OFF=1 ;day off
  .S Z=OFF,X="OFF" D SET
@@ -81,8 +79,4 @@
  I TYP["B" S NH=320,(NH(1),NH(2))=160,TH=192,(TH(1),TH(2))=96 ; Baylor NH=40 hrs to mimic full time, TH = 24 hrs for reality
  E  S TH=NH,TH(1)=NH(1),TH(2)=NH(2) ;total hrs for pp
- ; 
- ; Update NH for the nurses on the 36/40 AWS
- I "KM"[$E(AC,1),$E(AC,2)=1,NH=288 S NH=320,(NH(1),NH(2))=160,TH=320,(TH(1),TH(2))=160
- ;
  I TYP["W",L>1 S $P(WK(3),"^",3)=L ;last tour (IN) in misc for WG
  S VALOLD=$G(^PRST(458,+PY,"E",+DFN,5)) ;existing decomp
@@ -93,5 +87,5 @@
  ;
  ; Need to conditionally set Y $S(Y=0 mid=00:00, y=1: mid=24:00)
- ; based on whether exception is within or outside the tour.
+ ; based on whether exception is within or outsided tour.
  D MIL^PRSATIM ;convert to military (24hr) time
  I +Y<1000 S Y=$E("0000",0,4-$L(Y))_Y
Index: FOIAVistA/tag/r/PAID-PRS/PRS8VW.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8VW.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8VW.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8VW ;HISC/MRL-DECOMPOSITION, VIEW RESULTS ;03/22/07
- ;;4.0;PAID;**2,6,27,45,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8VW ;HISC/MRL-DECOMPOSITION, VIEW RESULTS ;11/4/97
+ ;;4.0;PAID;**2,6,27,45**;Sep 21, 1995
  ;
  ;This routine is used to view the results of the decomposition.
@@ -11,6 +10,4 @@
  ;Called by Routines:  PRS8, PRS8DR
  S (NEW,VAL)=$G(VAL),(OLD,VALOLD)=$G(VALOLD)
- N DASH1,DASH2
- S $P(DASH1,"-",79)="-",$P(DASH2,"=",79)="="
  I +$E(NEW,2,4) S NEW=$E(VAL,33,999) ; 33rd position because CP field
  I +$E(OLD,2,4) S OLD=$E(VALOLD,33,999) ;is added(either "C","F"or" ")
@@ -26,5 +23,5 @@
  S X="Pay Period: "_(^PRST(458,+PY,0)) W ?(79-$L(X)),$P(X,"^",1)
  D CTID
- W !,DASH2
+ W ! F I=1:1:79 W "="
  W !,"Loc.",?10,"Data Element",?44,"Code",?52,"Old Value",?67,"New Value"
  W !,"----",?10,"------------",?44,"----",?52,"---------",?67,"---------"
@@ -33,11 +30,9 @@
  D STUB
  I "C"'[$E(IOST) D
- .W !,DASH1
+ .W ! F I=1:1:79 W "-"
  .W !,TR
  D ONE^PRS8CV,^%ZISC Q
  ;
 CERT ; entry point to show supervisor result of decomp before certifying
- N DASH1,DASH2
- S $P(DASH1,"-",79)="-",$P(DASH2,"=",79)="="
  S (NEW,VAL)=$G(VAL)
  I +$E(NEW,2,4) S NEW=$E(VAL,33,999) ;because CP field is added to STUB
@@ -51,18 +46,18 @@
  .S X="Run Date: "_Y,TR=$E(TR,1,(79-$L(X)))_X
  S H="PAY PERIOD SUMMARY" W !,$J(H,40+($L(H)/2)),!
- S X=$P(C0,"^",1)_" [SSN: "_$E($P(C0,"^",9))_"XXXX"_$E($P(C0,"^",9),6,9)_"]" W !,X
+ S X=$P(C0,"^",1)_" [SSN: "_$P(C0,"^",9)_"]" W !,X
  S X="Pay Period: "_(^PRST(458,+PY,0)) W ?(79-$L(X)),$P(X,"^",1)
  D CTID
- W !,DASH2
+ W ! F I=1:1:79 W "="
  W !
  K I,L,X,USED
  D ^PRS8VW2
  I "C"'[$E(IOST) D
- .W !,DASH1
+ .W ! F I=1:1:79 W "-"
  .W !,TR
  K H,R,Z Q
 E2 ; --- create E array
- S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNTRSSRSDND"
- S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNHRNSSSHNU"
+ S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNT"
+ S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNH"
  S E(3)="NLDWMLCAPCCYFE" Q
 STUB ; --- show stub record
@@ -74,6 +69,6 @@
  ;
 E ; --- create E array
- S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNTRSSRSDND"
- S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNHRNSSSHNU"
+ S E(1)="ANSKWDNOAURTCECUUNNANBSPSASBSCDADBDCTFOAOBOCYAOKOMRARBRCHAHBHCPTPAONYDHDVCEAEBTATCFAFCADNT"
+ S E(2)="ALSLWPNPABRLCTCOUSNRNSSQSESFSGDEDFDGTGOEOFOGYEOSOURERFRGHLHMHNPHPBCLYHHOVSECEDTBTDFBFDAFNH"
  S E(3)="NLDWINTLLULNLDDTTOLAMLCAPCCYRRFFFECD" Q
 CTID ; compressed tour indicator display
Index: FOIAVistA/tag/r/PAID-PRS/PRS8VW1.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8VW1.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8VW1.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;01/23/07
- ;;4.0;PAID;**6,35,45,69,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8VW1 ;HISC/MRL-DECOMPOSITION, VIEW RESULTS, CONT. ;8/23/01
+ ;;4.0;PAID;**6,35,45,69**;Sep 21, 1995
  ;
  ;This routine is used to view the results of the decomposition.
@@ -18,5 +17,5 @@
  S E=E(3),W="Misc",LOC=0 D SHOW
  I 'CHECK,"C"'[$E(IOST) D
- .W !,DASH1
+ .W ! F I=1:1:79 W "-"
  .W !,TR
  K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q
@@ -31,5 +30,5 @@
  ..S FOUND(LOC(1))=$G(FOUND(LOC(1)))
  ..S $P(FOUND(LOC(1)),"^",$S(LOC<2:1,1:4))=X
- .S Y=$P($T(@($E(X)_"^PRS8VW2")),";;",2)
+ .S Y=$P($T(@$E(X)),";;",2)
  .S Y(1)=$F(Y,$E(X,2)_":")
  .S Y=$P($E(Y,Y(1),999),":",1,2)
@@ -55,2 +54,34 @@
  I 'S,LOC'=1 K FOUND(LOC(1))
  Q
+ ;
+ ; This internal table stores types of time codes and their
+ ; corresponding descriptions and TT8B value field lengths. Each
+ ; single char line label below is the 1st char of a type of time code.
+ ; The text on the corresponding line contains '^' delimited
+ ; pieces.  The 1st char of those pieces is the 2nd char of a type of
+ ; time.  The text description for that time code is given by the
+ ; the number in the 2nd ':' delimited piece.  That number indicates 
+ ; the line number below the label TYP in routine PRS8VW2.  The 3rd 
+ ; ':' delimited piece is the length of the time code's value in the 
+ ; TT8B String. 
+ ;
+A ;;N:1:3^U:5:3^L:1:3^B:5:3^D:63:3^F:63:3
+C ;;E:7:3^U:8:3^T:7:3^O:8:3^L:34:4^A:55:4^Y:57:3^D:60:6
+D ;;A:16:3^B:17:3^C:18:3^E:16:3^F:17:3^G:18:3^W:45:2^T:48:6
+E ;;A:38:5^B:40:5^C:38:5^D:40:5
+F ;;F:59:4^A:61:3^B:61:3^C:62:3^D:62:3^E:64:6
+H ;;A:29:3^B:30:3^C:31:3^L:29:3^M:30:3^N:31:3^D:36:3^O:36:3
+I ;;N:46:1
+L ;;U:48:4^N:49:4^D:50:4^A:53:1
+M ;;L:54:4
+N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3
+O ;;A:20:3^B:21:3^C:22:3^K:24:3^M:25:3^N:34:4^E:20:3^F:21:3^G:22:3^S:24:3^U:25:3
+P ;;T:32:3^A:33:3^H:32:3^B:33:3^C:56:2
+R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1
+S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3
+T ;;F:19:3^A:42:3^C:43:3^G:19:3^B:42:3^D:43:3^L:47:3^O:52:1
+U ;;N:9:3^S:9:3
+V ;;C:37:6^S:37:6
+W ;;D:3:3^P:3:3
+Y ;;A:23:3^D:35:4^E:23:3^H:35:4
+ Q
Index: FOIAVistA/tag/r/PAID-PRS/PRS8VW2.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8VW2.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8VW2.m	(revision 636)
@@ -1,5 +1,4 @@
-PRS8VW2 ;HISC/MRL,RTK-DECOMPOSITION, VIEW RESULTS ;03/28/07
- ;;4.0;PAID;**6,32,34,45,69,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8VW2 ;HISC/MRL,RTK-DECOMPOSITION, VIEW RESULTS ;09/27/01
+ ;;4.0;PAID;**6,32,34,45,69**;Sep 21, 1995
  ; 
  ; This routine is used to show the results of the decomp to
@@ -17,5 +16,5 @@
  S E=E(3),W="Misc",LOC=0 D SHOW
  I 'CHECK,"C"'[$E(IOST) D
- .W !,DASH1
+ .W ! F I=1:1:79 W "-"
  .W !,TR
  K %,CHECK,D,E,I,L,LOC,USED,W,X,Y Q
@@ -48,14 +47,6 @@
  Q
  ;
- ; This internal table stores types of time codes and their
- ; corresponding descriptions and TT8B value field lengths. Each
- ; single char line label below is the 1st char of a type of time code.
- ; The text on the corresponding line contains '^' delimited
- ; pieces.  The 1st char of those pieces is the 2nd char of a type of
- ; time.  The text description for that time code is given by the
- ; the number in the 2nd ':' delimited piece.  That number indicates
- ; the line number below the label TYP in routine PRS8VW2.  The 3rd
- ; ':' delimited piece is the length of the time code's value in the
- ; TT8B String.
+ ; See description of similar table in routine PRS8VW1 for 
+ ; explanation of table below.
  ;
 A ;;N:1:3^U:5:3^L:1:3^B:5:3^D:63:3^F:63:3
@@ -65,12 +56,12 @@
 F ;;F:59:4^A:61:3^B:61:3^C:62:3^D:62:3^E:64:6
 H ;;A:29:3^B:30:3^C:31:3^L:29:3^M:30:3^N:31:3^D:36:3^O:36:3
-I ;;N:46:1
-L ;;U:48:4^N:49:4^D:50:4^A:53:1
+I ;;N:46:1       
+L ;;U:48:4^N:49:4^D:50:4^A:53:1       
 M ;;L:54:4
-N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3^D:69:3^U:69:3
+N ;;O:4:3^A:10:3^B:11:3^P:4:3^R:10:3^S:11:3^L:44:2^T:65:3^H:65:3
 O ;;A:20:3^B:21:3^C:22:3^K:24:3^M:25:3^N:34:4^E:20:3^F:21:3^G:22:3^S:24:3^U:25:3
 P ;;T:32:3^A:33:3^H:32:3^B:33:3^C:56:2
-R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1^S:66:3^N:66:3
-S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3^R:67:3^S:67:3^D:68:3^H:68:3
+R ;;T:6:3^A:26:3^B:27:3^C:28:3^L:6:3^E:26:3^F:27:3^G:28:3^R:58:1
+S ;;K:2:3^P:12:3^A:13:3^B:14:3^C:15:3^L:2:3^Q:12:3^E:13:3^F:14:3^G:15:3
 T ;;F:19:3^A:42:3^C:43:3^G:19:3^B:42:3^D:43:3^L:47:3^O:52:1
 U ;;N:9:3^S:9:3
@@ -79,5 +70,5 @@
 Y ;;A:23:3^D:35:4^E:23:3^H:35:4
  ;
-TYP ; literal values of activities (actual name)
+TYP ; literal values of acitivites (actual name)
  ;;Annual Leave
  ;;Sick Leave
@@ -145,6 +136,2 @@
  ;;Fee Basis
  ;;Base Tour Non Pay Hours
- ;;Recess
- ;;Saturday Premium-AWS
- ;;Sunday Premium-AWS
- ;;Night Differential-AWS
Index: FOIAVistA/tag/r/PAID-PRS/PRS8WE2.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRS8WE2.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRS8WE2.m	(revision 636)
@@ -1,5 +1,5 @@
-PRS8WE2 ;WCIOFO/MGD-DECOMPOSITION, WEEKEND PREMIUM PART 2 ;3/23/07
- ;;4.0;PAID;**90,92,96,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRS8WE2 ;WCIOFO/MGD-DECOMPOSITION, WEEKEND PREMIUM PART 2 ;10/22/04
+ ;;4.0;PAID;**90,92,96**;Sep 21, 1995
+ ;
 COUNT(DAYN,SEG) ; Increase count of premium for tour
  ; input
@@ -41,7 +41,7 @@
  . . . Q:TOURS=1!(TOURS=4)  ; If on a Tour it counts as Premium
  . . . S RC=$P(TOUR,"^",POST+3)
- . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12),
- . . . ; CB - Premium T&L (#14) or OT/CT With Premiums (#17) to qualify for Premium pay.
- . . . I "^9^12^14^17^"'[("^"_RC_"^") S NOTELG=1
+ . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12)
+ . . . ; or CB - Premium T&L (#14) to qualify for Premium pay.
+ . . . I "^9^12^14^"'[("^"_RC_"^") S NOTELG=1
  . Q:FND
  . ;
@@ -61,7 +61,7 @@
  . . . Q:TOURS=1!(TOURS=4)  ; If on a Tour it counts as Premium
  . . . S RC=$P(TOUR,"^",POST+3)
- . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12),
- . . . ; CB - Premium T&L (#14) or OT/CT With Premiums to qualify for premium pay.
- . . . I "^9^12^14^17^"'[("^"_RC_"^") S NOTELG=1
+ . . . ; Remarks Code must be OT/CT on Premium (#9), Tour Coverage (#12)
+ . . . ; or CB - Premium T&L (#14) to qualify for premium pay.
+ . . . I "^9^12^14^"'[("^"_RC_"^") S NOTELG=1
  ;
  I $E(H(DAYN),SEG)=1!($E(P(DAYN),SEG)=5) Q
@@ -85,8 +85,4 @@
  . . . . . . I "^2^3^"[(U_SHIFT_U) S FND=1
  ;
- ;Set shift 2 for 36/40 AWS nurses with premium time outside tour
- ;for this time segment  i.e. overtime(O), comp time(C) or called in from
- ;on-call(c)
- I +NAWS=36,"cOE"[$E(D(DAYN),SEG) S SHIFT=2
  ; add to count
  S CNT(DAYN,SHIFT)=$G(CNT(DAYN,SHIFT))+1
@@ -105,9 +101,4 @@
  . . S AMT=CNT(DAYN,SHIFT)
  . . S PC=$S(TP="SAT":0,1:SHIFT)+12
- . . ;Shift 2 used for 36/40 nurses premium time within tour using the 2080 divisor (40*52).
- . . ;Saturday Premium-AWS (SR/SS) and Sunday Premium-AWS (SD/SH)
- . . ;Paid at the AAC with the 1872 divisor for the hourly rate (36*52)
- . . ;for time outside the tour.
- . . S:+NAWS=36 PC=$S(SHIFT=2:$S(TP="SAT":12,1:13),TP="SAT":49,1:50)
  . . S $P(WK(WEEK),U,PC)=$P(WK(WEEK),U,PC)+AMT
  Q
Index: FOIAVistA/tag/r/PAID-PRS/PRSACED2.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSACED2.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSACED2.m	(revision 636)
@@ -1,5 +1,4 @@
 PRSACED2 ; HISC/FPT-T&A Edits ;11/24/1999
- ;;4.0;PAID;**45,54,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;4.0;PAID;**45,54**;Sep 21, 1995
  ;
  ; initialize array that stores 8b values.  This array is used
@@ -36,6 +35,5 @@
 E2 I NOR=112,DUT=1,'$P(C0,"^",42)!('$P(C1,"^",24)) S ERR=67 D ERR^PRSACED
  I E(9),'$P(C1,"^",46),E(9)'=+NOR S ERR=65 D ERR^PRSACED
- ;exclude 9/3 month employee
- I DUT=2,'(NOR="01"&("LMN"[PAY)),'(NOR="80"&(PAY="M")),$P(C0,"^",42)=""!($P(C1,"^",24)="") S ERR=66 D ERR^PRSACED
+ I DUT=2,'(NOR="01"&("LMN"[PAY)),$P(C0,"^",42)=""!($P(C1,"^",24)="") S ERR=66 D ERR^PRSACED
  G ^PRSACED3
 OA ;
Index: FOIAVistA/tag/r/PAID-PRS/PRSACED5.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSACED5.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSACED5.m	(revision 636)
@@ -1,6 +1,4 @@
-PRSACED5 ; HISC/REL/FPT/PLT-T&A Cross-Edits ;11/20/06  12:53
- ;;4.0;PAID;**102,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
+PRSACED5 ; HISC/REL/FPT-T&A Cross-Edits ;02/07/06  12:53
+ ;;4.0;PAID;**102**;Sep 21, 1995
  G D1:DUT=1,D2:DUT=2,D3:DUT=3 Q
 D1 G:+NOR N1
@@ -13,6 +11,5 @@
  I LVG=5 I E(1)+E(2)+$P(C1,"^",30)>14 S ERR=160 D ERR^PRSACED
  Q
- ;36/40 employee has 8b normal hour = 72
-N1 I '(NOR=48!(NOR=72)&("KM"[PAY)),NOR<80 S ERR=153 D ERR^PRSACED
+N1 I '(NOR=48&("KM"[PAY)),NOR<80 S ERR=153 D ERR^PRSACED
  I '(PAY="W"&(LVG=0)),"123"'[LVG S ERR=154 D ERR^PRSACED
  S E(1)=0 F K=13:1:18,20,43 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25)
@@ -27,10 +24,8 @@
  I CWK="C",E(1)+E(2)>80 S ERR=166 D ERR^PRSACED
  Q
- ;exclude 9/3 month employee
-D2 I PAY'="M"!(FLSA'="E"),NOR<1!(NOR>79) S ERR=155 D ERR^PRSACED
+D2 I NOR<1!(NOR>79) S ERR=155 D ERR^PRSACED
  I "0123"'[LVG S ERR=156 D ERR^PRSACED
  I "ABCGLMNRU0123456789PQT"'[PAY S ERR=157 D ERR^PRSACED
- ;exclude 9/3 month employee
- QUIT:"123"'[LVG!(NOR="80"&(PAY="M"))
+ Q:"123"'[LVG
  S E(1)=0 F K=13:1:18,20,43 S X=$P(C0,"^",K),E(1)=E(1)+$E(X,1,2)+($E(X,3)*.25)
  S E(2)=0 F K=48:1:53 S X=$P(C0,"^",K),E(2)=E(2)+$E(X,1,2)+($E(X,3)*.25)
Index: FOIAVistA/tag/r/PAID-PRS/PRSACED6.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSACED6.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSACED6.m	(revision 636)
@@ -1,10 +1,9 @@
 PRSACED6 ; HISC/FPT-T&A Cross-Edits ;11/27/95  10:01
- ;;4.0;PAID;**6,45,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;4.0;PAID;**6,45**;Sep 21, 1995
 CODES ; Set variables T0 and T1 with 8B code list
- ;      1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
+ ;      1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59
  ;
  S T0="AN SK WD NO AU RT CE CU UN NA NB SP DA SA SB SC OA OB OC OK DB OM RA RB RC HA HB HC HD PT PA ON VC EA EB AL SL WP NP AB RL FA FB FC FD AD AF FE",N1=60
- S T1="CT CO US NR NS DC TF SE SF SG OE OF OG OS TA OU RE RF RG HL HM HN HO PH PB CL VS EC ED NL DW IN TL LU LN LD TO LA ML CA PC TC CY RR SQ FF DE DF YA DG TG YD YE TB DT YH TD NT NH RS RN ND NU SR SS SD SH",N2=67
+ S T1="CT CO US NR NS DC TF SE SF SG OE OF OG OS TA OU RE RF RG HL HM HN HO PH PB CL VS EC ED NL DW IN TL LU LN LD TO LA ML CA PC TC CY RR SQ FF DE DF YA DG TG YD YE TB DT YH TD NT NH",N2=59
  Q
 STUB ; parse out 'stub' variables from 8b record
Index: FOIAVistA/tag/r/PAID-PRS/PRSAENT.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSAENT.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSAENT.m	(revision 636)
@@ -1,5 +1,4 @@
 PRSAENT ;HISC/MGD-Entitlement String ;10/21/04
- ;;4.0;PAID;**6,21,45,69,75,76,90,96,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;4.0;PAID;**6,21,45,69,75,76,90,96**;Sep 21, 1995
  ;
  ;VARS:
@@ -102,5 +101,4 @@
  S LVG=$P(C0,"^",15) S:LVG=5 AC=AC_"*" Q
 M I $E(AC,2)=1,NH=48 S AC=AC_"B" Q
- I $E(AC,2)=2,NH=80 S AC=AC_"R" Q
  I $E(AC,2)=2 S PB=$P(C0,"^",20) I PB=0 S AC=AC_"0" Q
  I $E(AC,2)=3 S PB=$P(C0,"^",20) I PB=2 S AC=AC_"2" Q
Index: FOIAVistA/tag/r/PAID-PRS/PRSAENX.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSAENX.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSAENX.m	(revision 636)
@@ -1,5 +1,4 @@
 PRSAENX ; HISC/REL-List Entitlement ;3/12/93  12:58
- ;;4.0;PAID;**34,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;4.0;PAID;**34**;Sep 21, 1995
  K DIC S DIC="^PRST(457.5,",DIC(0)="AEQM" W ! D ^DIC G:Y<1 EX S ENT=^PRST(457.5,+Y,1),NAM=$P(Y,"^",2)
  W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP EX
@@ -19,7 +18,7 @@
 1 ;;Regular Scheduled
 2 ;;Regular Unscheduled
-3 ;;FF Reg. Sch. Hrs. Over 53
-4 ;;Reserved for future use
-5 ;;Recess Periods
+3 ;;Reg. Hrs. at OT Rate - Day
+4 ;;Reg. Hrs. at OT Rate - 2
+5 ;;Reg. Hrs. at OT Rate - 3
 6 ;;Night Differential - 2
 7 ;;Night Differential - 3
Index: FOIAVistA/tag/r/PAID-PRS/PRSALVS.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSALVS.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSALVS.m	(revision 636)
@@ -1,5 +1,4 @@
-PRSALVS ;HISC/REL-Display Leave Request ;11/21/06
- ;;4.0;PAID;**9,69,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRSALVS ;HISC/REL-Display Leave Request ;09/21/01
+ ;;4.0;PAID;**9,69**;Sep 21, 1995
  S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9) I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0))
  I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
@@ -48,10 +47,8 @@
  S EDT=$P($G(^PRST(458.1,DA,0)),"^",5) I EDT'>SDT G B3
  S X1=EDT,X2=SDT D ^%DTC S INC=X+13\14*$S(Z="AL":AINC,1:SINC)
- I NH=80,DB=2 S X1=EDT,X2=X+13\14*14-X D C^%DTC S INC=INC-$$RT(X,SDT) S:INC<0 INC=0
  I PRT W !,Z," Estimated Earnings: ",$J(INC,8,3)
  S LST=9999999-SDT,CNT=0
  F DTI=0:0 S DTI=$O(^PRST(458.1,"AD",DFN,DTI)) Q:DTI=""!(DTI>LST)  F RDA=0:0 S RDA=$O(^PRST(458.1,"AD",DFN,DTI,RDA)) Q:RDA=""  I $G(^(RDA))'>EDT D
  .S Z1=$G(^PRST(458.1,RDA,0)) S X1=$P(Z1,"^",7) S:"CB AD"[X1 X1="SL" Q:X1'=Z  Q:"AR"'[$P(Z1,"^",9)
- .I NH=72,DB=1 S $P(Z1,U,15)=$$LC($P(Z1,U,15))
  .S CNT=CNT+$P(Z1,"^",15)
  .I $P(Z1,"^",3)'<SDT,$P(Z1,"^",5)'>EDT Q
@@ -66,17 +63,6 @@
 HDR ; Display Header
  W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!?32,"LEAVE REQUESTS"
- S X=$G(^PRSPC(DFN,0)) W !!,$P(X,"^",1) S X=$P(X,"^",9) I X W ?50,"XXX-XX-",$E(X,6,9) Q
+ S X=$G(^PRSPC(DFN,0)) W !!,$P(X,"^",1) S X=$P(X,"^",9) I X W ?50,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) Q
 H1 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1 I 'QT W @IOF,!
  Q
 EX G KILL^XUSCLEAN
- ;Multiply leave request by 1.111 and round down to the quarter hour
- ;for 36/40 nurses
-LC(X) S X=X*1.111\.25*.25 Q X
- ;Calculate number of Recess hours scheduled for a 9-month AWS Nurse 
- ;before the date leave has been requested for
-RT(EDT,SDT) N SFY,EFY,T,WK
- S SFY=$E($P($$GETFSCYR^PRSARC04(SDT),U,2),3,6),EFY=$E($P($$GETFSCYR^PRSARC04(EDT),U,2),3,6)
- D RES^PRSARC05(.WK,DFN,SFY,EFY,SDT,EDT) S (I,T)=0 F  S I=$O(WK(I)) Q:I=""  S T=T+WK(I)
- ;Calculate the number of hours of leave that would have been
- ;accumulated for the time the nurse was on recess.
- Q T/80*$S(Z="AL":AINC,1:SINC)\.25*.25
Index: FOIAVistA/tag/r/PAID-PRS/PRSAOTT.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSAOTT.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSAOTT.m	(revision 636)
@@ -1,5 +1,4 @@
-PRSAOTT ;WCIOFO/JAH/PLT- 8B CODES ARRAY.  COMPARE OT (8B-vs-APPROVED). ;11/29/2006
- ;;4.0;PAID;**37,43,54,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRSAOTT ;WCIOFO/JAH- 8B CODES ARRAY.  COMPARE OT (8B-vs-APPROVED). ;11/29/1999
+ ;;4.0;PAID;**37,43,54**;Sep 21, 1995
  ;
  ;Function & subroutine Index for this routine.
@@ -227,7 +226,7 @@
  ;
  Q:$G(WEEK)="" 0
- Q:WEEK=1 "AN SK WD NO AU RT CE CU UN NA NB SP SA SB SC DA DB DC TF OA OB OC YA OK OM RA RB RC HA HB HC PT PA ON YD HD VC EA EB TA TC FA FC AD NT RS ND SR SD"
- ;
- Q:WEEK=2 "AL SL WP NP AB RL CT CO US NR NS SQ SE SF SG DE DF DG TG OE OF OG YE OS OU RE RF RG HL HM HN PH PB CL YH HO VS EC ED TB TD FB FD AF NH RN NU SS SH"
+ Q:WEEK=1 "AN SK WD NO AU RT CE CU UN NA NB SP SA SB SC DA DB DC TF OA OB OC YA OK OM RA RB RC HA HB HC PT PA ON YD HD VC EA EB TA TC FA FC AD"
+ ;
+ Q:WEEK=2 "AL SL WP NP AB RL CT CO US NR NS SQ SE SF SG DE DF DG TG OE OF OG YE OS OU RE RF RG HL HM HN PH PB CL YH HO VS EC ED TB TD FB FD AF"
  ;
  Q:WEEK=3 "NL DW IN TL LU LN LD DT TO LA ML CA PC CY RR FF FE CD"
Index: FOIAVistA/tag/r/PAID-PRS/PRSAPPH.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSAPPH.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSAPPH.m	(revision 636)
@@ -1,4 +1,4 @@
-PRSAPPH ; WOIFO/JAH - Holiday Utilities ;12/07/07
- ;;4.0;PAID;**33,66,113,112,116**;Sep 21, 1995;Build 23
+PRSAPPH ; HISC/REL-Holiday Utilities ;01/03/07
+ ;;4.0;PAID;**33,66,113**;Sep 21, 1995;Build 3
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  K HOL S PDT=$G(^PRST(458,PPI,1)) Q:PDT=""  S X1=$P(PDT,"^",1),X2=-6 D C^%DTC
@@ -14,5 +14,5 @@
 E0 ; Find Benefit Day
  Q:DAY=15  I DAY>0,DAY<15 G P0
- Q:DB'=1  Q:NH=48!(NH=72)  G P1:DAY<0,P3:DAY>14
+ Q:DB'=1  Q:NH=48  G P1:DAY<0,P3:DAY>14
 P0 S TC=$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) Q:'TC
  I (TC=3)!(TC=4) G U1
@@ -21,5 +21,5 @@
  I TC=2!$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",8)!$P($G(^(0)),"^",14),'$P($G(^(0)),"^",12) G S0
  Q:$P($G(^(0)),"^",12)=LLL&(TT="HX") 
- G U1:DB=2!(NH=72) I FLX'="C" G EF:(DAY#7=1),EB:(DAY#7=0)
+ G:DB=2 U1 I FLX'="C" G EF:(DAY#7=1),EB:(DAY#7=0)
  S C=0 F X1=$S(DAY<8:1,1:8):1:DAY I '$P($G(^PRST(458,PPI,"E",DFN,"D",X1,0)),"^",8),'$P($G(^(0)),"^",14) S C=C+1
  I FLX'="C" G EF:C<2,EB
Index: FOIAVistA/tag/r/PAID-PRS/PRSAPPO.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSAPPO.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSAPPO.m	(revision 636)
@@ -1,4 +1,4 @@
-PRSAPPO ; HISC/MGD - Open New Pay Period ;07/30/07
- ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54
+PRSAPPO ; HISC/MGD - Open New Pay Period ;03/15/06
+ ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  S PPI=$P(^PRST(458,0),"^",3),PPE=$P(^PRST(458,PPI,0),"^",1)
@@ -27,7 +27,4 @@
  .I $P($G(^PRSPC(DFN,1)),"^",20)="Y" Q
  .I $P($G(^PRSPC(DFN,1)),"^",33)'="N" Q
- .S C0=^PRSPC(DFN,0)
- .I $P(C0,U,10)=2,$P(C0,U,16)=80 S NAWS="9Mo AWS",CT9=$G(CT9)+1
- .I $P(C0,U,10)=1,$P(C0,U,16)=72 S NAWS="36/40 AWS",CT36=$G(CT36)+1
  .S PRSIEN=DFN,MDAT=$P(PDT,U,1)
  .S MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT)
@@ -37,22 +34,7 @@
  .I $G(MIEN) D PLPP^PRSPLVA(PRSIEN,PPI)
  .;
- .; Call to Autopost PT Phy Extended Absence
+ .; Call to autopost PT Phy Extended Absence
  .I $G(MIEN) D PEAPP^PRSPEAA(PRSIEN,PPI)
  .S N=N+1 W:N#100=0 "." Q
- ;SEND A MESSAGE WHEN A 9 MONTH AWS NURSE IS ACTIVATED AT A SITE
- I +$G(NAWS) D
- .I $G(CT9) S TMP(1)=CT9_" 9 month AWS nurse(s) set up"
- .I $G(CT36) S TMP(2)=CT36_" 36/40 AWS nurse(s) set up"
- .S S=$$KSP^XUPARAM("INST")_"," D FIND^DIC(456,,,"Q",+S)
- .S IND=$S($D(^TMP("DILIST",$J,0)):+^(0),1:$O(^PRST(456,0)))
- .S CM9=$$GET1^DIQ(456,IND,2),CM36=$$GET1^DIQ(456,IND,4)
- .S MAX=$$GET1^DIQ(456,IND,3) N FDA,DIERR
- .I $G(CT9),CM9<MAX S FDA(456,IND_",",2)=CM9+1
- .I $G(CT36),CM36<MAX S FDA(456,IND_",",4)=CM36+1
- .Q:'$D(FDA)  D FILE^DIE("","FDA"),MSG^DIALOG()
- .S S=$$GET1^DIQ(4,+S,99)_" "_$$GET1^DIQ(4,+S,100),XMTEXT="TMP("
- .S TMP(3)="At "_S,XMDUZ=.5,XMY("VHAOIPAIDETANAWSBULLETIN@VA.GOV")=""
- .S XMSUB=+S_" 36/40, 9 month AWS nurse(s) deployed PRS*4.0*112"
- .D ^XMD K TMP
  S $P(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N W !!,N," Employee Records created.",!
 EX G KILL^XUSCLEAN
Index: FOIAVistA/tag/r/PAID-PRS/PRSASR.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSASR.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSASR.m	(revision 636)
@@ -1,4 +1,4 @@
-PRSASR ;HISC/MGD,WOIFO/JAH/PLT - Supervisor Certification ;02/05/2005
- ;;4.0;PAID;**2,7,8,22,37,43,82,93,112**;Sep 21, 1995;Build 54
+PRSASR ;HISC/MGD,WOIFO/JAH - Supervisor Certification ;02/05/2005
+ ;;4.0;PAID;**2,7,8,22,37,43,82,93**;Sep 21, 1995;Build 7
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -79,9 +79,8 @@
  ;     ---------------------------------------------------
 CHK ; Check for needed approvals
- N PRSENT,PRSWOC
  S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) I "PX"[STAT Q
  I USR=DFN Q:'$D(^XUSEC("PRSA SIGN",DUZ))
  E  I CKS S SSN=$P($G(^PRSPC(DFN,0)),"^",9) I SSN S EDUZ=+$O(^VA(200,"SSN",SSN,0)) I $D(^PRST(455.5,"AS",EDUZ,TLI)) Q:$P($G(^PRST(455.5,TLI,"S",EDUZ,0)),"^",2)'=TLE
- S HDR=0 D HDR,^PRSAENT S PRSENT=ENT
+ S HDR=0 D HDR
  ;
  ;Loop to display tour, exceptions(leave, etc..) & errors.
@@ -111,10 +110,4 @@
  .  D WARNSUP^PRSAOTT(PPE,DFN,VAL,WK,.OTERR,.O8,.OA)
  .  I OTERR S ^TMP($J,"OT",DFN,WK)=O8_"^"_OA
- ;
- ;warning message for rs/rn and on type of time
- I $E(PRSENT,5) D
- . I @($TR($$CD8B^PRSU1B2(VAL,"RS^3^RN^3",1),U,"+")_"-("_$TR($$RSHR^PRSU1B2(DFN,PPI),U,"+")_")") W !,?3,"WARNING: The total scheduled recess hours for this pay period does not match the total RS/RN posted."
- . I $G(PRSWOC)]"" W !,?3,"Warning: The entire tour for day# ",PRSWOC," is posted RECESS. The On-Call will be paid unless posted UNAVAILABLE."
- . QUIT
  ;
 LD ; Check for changes to the Labor Distribution Codes made during the pay
@@ -170,5 +163,5 @@
 HDR ; Display Header
  I HDR S QT=$$ASK^PRSLIB00() Q:QT
- S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X),"XX-XX-",$E(X,6,9) S HDR=1
+ S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9) S HDR=1
  W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
  W !?3 F I=1:1:72 W "-"
@@ -178,5 +171,5 @@
  N HOLD
  S HOLD=$$ASK^PRSLIB00(1)
- S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X),"XX-XX-",$E(X,6,9)
+ S X=$G(^PRSPC(DFN,0)) W !,@IOF,?3,$P(X,"^",1) S X=$P(X,"^",9) I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
  W !,?6,"Date",?20,"Scheduled Tour",?40,"Tour Exceptions",?63,IORVON,"Tour Errors",IORVOFF
  W !?3 F I=1:1:72 W "-"
@@ -193,5 +186,5 @@
  Q
  ;
- ;
+ ;====================================================================
  ;These extrinsic functions simply remove lengthy code from long, 
  ;single line, nested loop.
Index: FOIAVistA/tag/r/PAID-PRS/PRSASR1.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSASR1.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSASR1.m	(revision 636)
@@ -1,4 +1,4 @@
-PRSASR1 ;WCIOFO/JAH - Display VCS, Fee, ED ;02/20/08
- ;;4.0;PAID;**6,21,82,93,116**;Sep 21, 1995;Build 23
+PRSASR1 ;HISC/MGD - Display VCS, Fee, ED ;04/19/05
+ ;;4.0;PAID;**6,21,82,93**;Sep 21, 1995;Build 7
  ;;Per VHA Directive 2004-038, this routine should not be modified.
 VCS ; Display VCS Sales/Fee Basis
@@ -93,5 +93,5 @@
  W !,@IOF,?3,$P(X,"^",1)
  S X=$P(X,"^",9)
- I X W ?68,$E(X),"XX-XX-",$E(X,6,9)
+ I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
  W !,DASH
  D LDHDR
Index: FOIAVistA/tag/r/PAID-PRS/PRSATE.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSATE.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSATE.m	(revision 636)
@@ -1,4 +1,4 @@
 PRSATE ;WCIOFO/JAH - Enter/Edit Employee (emp) Tour of Duty (ToD) ;03/15/2005
- ;;4.0;PAID;**8,11,27,45,55,93,112**;Sep 21, 1995;Build 54
+ ;;4.0;PAID;**8,11,27,45,55,93**;Sep 21, 1995;Build 7
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  N PPI,PPE,PRSTLV,TLI,TLE,DFN
@@ -46,5 +46,5 @@
  ; Display header/Ask pp (NOL^PRSATE2 returns SRT = Current, Next, Last)
  ;
- D NOW^%DTC S NOW=% K %
+ D NOW^%DTC S NOW=%
  W:$E(IOST,1,2)="C-" @IOF
  W !?26,"VA TIME & ATTENDANCE SYSTEM"
@@ -97,5 +97,5 @@
  ...    E  D
  ....      S NOERROR=1
- K NOW Q
+ Q
  ;=======================
  ;
@@ -120,5 +120,5 @@
  ; ask TK about all others.
  ;
- S DB=$P(C0,U,10) I FLX="C"!("KM"[PP&(DB=1)&(NH=72)) D
+ I FLX="C" D
  .   D VAR
  E  D
@@ -128,5 +128,5 @@
  ..    D VAR
  .  E  D FX
- K DB Q
+ Q
  ;=======================
  ;
@@ -147,5 +147,5 @@
  .  W "  ... done" D:HRS'=NH ERROR(2,NH,HRS)
  .  D T2,^PRSATE5
- D HOL,RS K HRS,STR
+ D HOL,RS
  Q
  ;=======================
@@ -205,5 +205,5 @@
  S $P(^PRST(458,PPI,"E",DFN,0),U,$S(SRT="N":7,1:6))=Y
  I $D(^PRST(458,"ATC",DFN)) D UPD^PRSASAL
- K PAY,ZENT Q
+ Q
  ;=======================
  ;
@@ -268,5 +268,5 @@
  ;
  D S1
- K OLD,SCH Q
+ Q
  ;=======================
  ;
@@ -298,5 +298,5 @@
  Q:'$D(HOL)
  S TT="HX",DUP=1
- D E^PRSAPPH K DUP,HOL,TT
+ D E^PRSAPPH
  Q
  ;=======================
@@ -332,5 +332,6 @@
  S DIR("?",1)="Fixed tours are Monday - Friday with the same hours."
  D ^DIR
- Q $S(Y=1:"Y",Y=0:"N",1:"^")
+ S RESP=$S(Y=1:"Y",Y=0:"N",1:"^")
+ Q RESP
  ;=======================
  ;
@@ -343,5 +344,6 @@
  S DIR("?")="Enter ^ to escape and cancel this tour change."
  D ^DIR
- Q $S(Y=1:"Y",Y=0:"N",1:"^")
- ;=======================
- ;
+ S RESP=$S(Y=1:"Y",Y=0:"N",1:"^")
+ Q RESP
+ ;=======================
+ ;
Index: FOIAVistA/tag/r/PAID-PRS/PRSATE0.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSATE0.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSATE0.m	(revision 636)
@@ -1,7 +1,6 @@
 PRSATE0 ; HISC/REL-Edit Variable Tours ;5/30/95  14:37
- ;;4.0;PAID;**112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;4.0;PAID;;Sep 21, 1995
  S TOLD="" F K=1:1:14 S Z=$P($G(^PRST(458,PPI,"E",DFN,"D",K,0)),"^",2),$P(TOLD,"^",K)=Z I SRT="N",$P($G(^(0)),"^",3) S $P(TOLD,"^",K)=$P(^(0),"^",4)
- K K S ^PRST(458,PPI,"E",DFN,"T")=TOLD D DT^PRSATE2
+ S ^PRST(458,PPI,"E",DFN,"T")=TOLD D DT^PRSATE2
  K DDSFILE,DA,DR,PRSAERR S DDSFILE=458,DDSFILE(1)=458.01,DA(1)=PPI,DA=DFN
  S DR="[PRSA TE EDIT]" D ^DDS K DS Q:$D(PRSAERR)
@@ -9,5 +8,5 @@
  I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14"
  F DAY=1:1:14 S TD=$P(TNEW,"^",DAY) I TD>0 D S1
- K TNEW,TOLD Q
+ Q
 S1 ; Set Tour if necessary
  I TD=$P(TOLD,"^",DAY),$G(^PRST(457.1,+TD,1))=$G(^PRST(457.1,+$P(TOLD,"^",DAY),1)) Q
@@ -21,20 +20,8 @@
  Q
 VAL ; Validate Tour
- N NAWS,SNAWS,TDT S (ZENT,STR)="" K PRSAERR D OT^PRSATP S DB=$P(C0,U,10) I "KM"[PP,DB=1,NH=72 S NAWS=1
- S (HRS,TRS,TDT)=0 F DAY=1:1:14 D  I STR'="" G V1
- .S TD=$$GET^DDSVAL(DIE,.DA,DAY+200),Z=$P($G(^PRST(457.1,+TD,0)),"^",6) S:Z HRS=HRS+Z S Y=$G(^(1))
- .I DAY=7!(DAY=14)&'TDT S TDT=$P($G(^PRST(457.1,+TD,0)),U,5)="Y"
- .I $D(NAWS) S:Z'=12&Z NAWS=0 S $P(SNAWS,U,DAY)=TD I Z=12 S NAWS(DAY-1\7+1)=$G(NAWS(DAY-1\7+1))+1
- .D VS S:TRG TRS=TRS+1
+ S (ZENT,STR)="" K PRSAERR D OT^PRSATP
+ S (HRS,TRS)=0 F DAY=1:1:14 S TD=$$GET^DDSVAL(DIE,.DA,DAY+200) S Z=$P($G(^PRST(457.1,+TD,0)),"^",6) S:Z HRS=HRS+Z S Y=$G(^(1)) D VS S:TRG TRS=TRS+1 I STR'="" G V1
  I FLX="C",TRS>9 S STR="Warning: Compressed Schedule has more than 9 Tours!" D HLP^DDSUTL(.STR)
  I NH'=HRS,NH'=112 S STR="Warning: Normal Hours are "_NH_"; Tour Hours are "_HRS D HLP^DDSUTL(.STR)
- I $D(NAWS) D
- .I $G(NAWS(1))'=3!($G(NAWS(2))'=3)!'NAWS S STR=$P($T(NAWS1),";",3) D HLP^DDSUTL(.STR)
- .D TOURHRS^PRSARC07(.HRS,PPI,DFN,SNAWS)
- .I $G(HRS("W1"))'=36!($G(HRS("W2"))'=36) S STR=$P($T(NAWS2),";",3) D HLP^DDSUTL(.STR)
- .I $G(TDT) S STR=$P($T(NAWS3),";",3) D HLP^DDSUTL(.STR)
- K K,STR,TRG,TRS Q
-V1 S (DDSERROR,PRSAERR)=1 D HLP^DDSUTL(.STR) K DDSERROR Q
-NAWS1 ;;Warning: There are not three 12 hour tours in week 1 and/or week 2 for this AWS 36/40 Nurse
-NAWS2 ;;Warning: Hours in week 1 and/or week 2 are not 36 for this AWS 36/40 Nurse.
-NAWS3 ;;Warning: Tour overlaps two administrative work weeks for this 36/40 Nurse.
+ Q
+V1 S (DDSERROR,PRSAERR)=1 D HLP^DDSUTL(.STR) Q
Index: FOIAVistA/tag/r/PAID-PRS/PRSATP.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSATP.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSATP.m	(revision 636)
@@ -1,4 +1,4 @@
-PRSATP ;HISC/REL,WIRMFO/MGD/PLT - Timekeeper Post Time ;11/21/06
- ;;4.0;PAID;**22,57,69,92,102,93,112**;Sep 21, 1995;Build 54
+PRSATP ;HISC/REL,WIRMFO/MGD - Timekeeper Post Time ;3/21/06
+ ;;4.0;PAID;**22,57,69,92,102,93**;Sep 21, 1995;Build 7
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ; input (from calling option)
@@ -86,10 +86,12 @@
  ; ML to list if they are.  Added to be compliant with Public Law
  ; 106-554.
- S:$E(ENT,34) Z1=Z1_" 34",Z2=Z2_" ML"
- ;9/3 month employee entitled RS with recess hours in file# 458.8
- S:$E(ENT,5)&$P($$RSHR^PRSU1B2(DFN,PPE),U,DAY>7+1) Z1=Z1_" 5",Z2=Z2_" RS"
- F K=1:1:$L(Z1," ") I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" "
- QUIT
  ;
+ I $E(ENT,34) D
+ . S Z1=Z1_" 34",Z2=Z2_" ML"
+ . F K=1:1:14 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" "
+ ;
+ I '$E(ENT,34) D
+ . F K=1:1:13 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" "
+ Q
 OT ; Get entitled out-of-tour types of time
  S Z1="12 28 26",Z2="OT CT ON" F K=1:1:3 I $E(ENT,$P(Z1," ",K)) S ZENT=ZENT_$P(Z2," ",K)_" " I ZENT'["UN" S ZENT=ZENT_"UN "
Index: FOIAVistA/tag/r/PAID-PRS/PRSATP1.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSATP1.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSATP1.m	(revision 636)
@@ -1,5 +1,4 @@
-PRSATP1 ; HISC/REL,WOIFO/PLT - Daily Post verification ;11/28/2006
- ;;4.0;PAID;**34,57,112**;Sep 21, 1995;Build 54
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRSATP1 ; HISC/REL-Daily Post verification ;2/28/2000
+ ;;4.0;PAID;**34,57**;Sep 21, 1995
  ;routine is called to validate data entered during the 
  ;screenman posting of an employees pay period
@@ -12,21 +11,10 @@
  .I Z2>2880 D E5 Q
  .I $P(Z,"^",K+2)="" D E9 Q
- .;check duplicate start time if no rs-type of time in exception string z for node 2
- .I Z'["^RS",'(Z["HX"&("ON HW"[$P(Z,"^",K+2))),'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")),$D(T(Z1)) D E3 Q
+ .I '(Z["HX"&("ON HW"[$P(Z,"^",K+2))),'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")),$D(T(Z1)) D E3 Q
  .I $P(Z,"^",K+2)="HW",Z'["HX",'$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",12) D E7 Q
- .I $P(Z,"^",K+2)'="" S T(Z1)=$G(T(Z1))_$P(Z,U,K+2)_U,T(Z1,K)=Z2_"^"_$P(Z,"^",K,K+3)
+ .I $P(Z,"^",K+2)'="" S T(Z1,K)=Z2_"^"_$P(Z,"^",K,K+3)
  .Q
  I '$D(T) Q
- ;check duplicate start time if rs in exception string z for node 2.
- S Z1="" I Z["^RS",'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")) F  S Z1=$O(T(Z1)) QUIT:Z1=""  QUIT:Z["HX"&("^ON^HW^"[T(Z1))  I $L(T(Z1),U)>2 D  QUIT:Z1="*"
- . N A
- . S A=T(Z1),A=U_A
- . I $L(A,U)>4 S Z1="*" QUIT
- . I A'["^RS^" S A=$P(A,"^ON")_$P(A,"^ON",2) S:A="" A="^ON" I "^CT^"'[A,"^OT^"'[A,Z'["^HX"!("^HW^"'[A) S Z1="*" QUIT
- . I A["^RS^" S A=$P(A,"^RS")_$P(A,"^RS",2) S:A="" A="^RS" I "^CT^OT^RG^ON^HW^"'[A S Z1="*" QUIT
- . QUIT
- G:Z1="*" E3
- ;exclude rs with ct, ot, rg, on, hw for error e2 check
- I Z'["HX",'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")) S Z1="" F  S Z1=$O(T(Z1)) Q:Z1=""  G:Z1'<T(Z1,$O(T(Z1,0))) E1 S Y=$O(T(Z1)) I Y,T(Z1,$O(T(Z1,0)))>Y G E2:'(T(Z1)["RS^"&("^CT^OT^RG^ON^HW^"[T(Y)))&'("^CT^OT^RG^ON^HW^"[T(Z1)&(T(Y)["RS^"))
+ I Z'["HX",'(Z["^ON"&(Z["OT")),'(Z["^ON"&(Z["CT")) S Z1="" F  S Z1=$O(T(Z1)) Q:Z1=""  G:Z1'<T(Z1,$O(T(Z1,0))) E1 S Y=$O(T(Z1)) I Y,T(Z1,$O(T(Z1,0)))>Y G E2
  S Z1="",LL=1 F  S Z1=$O(T(Z1)) Q:Z1=""  F K=0:0 S K=$O(T(Z1,K)) Q:K<1  D
  .S $P(ZS,"^",LL)=$P(T(Z1,K),"^",2),$P(ZS,"^",LL+1)=$P(T(Z1,K),"^",3),$P(ZS,"^",LL+2)=$P(T(Z1,K),"^",4) S:$P(T(Z1,K),"^",5)'="" $P(ZS,"^",LL+3)=$P(T(Z1,K),"^",5)
Index: FOIAVistA/tag/r/PAID-PRS/PRSATPE.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSATPE.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSATPE.m	(revision 636)
@@ -1,35 +1,11 @@
-PRSATPE ;WOIFO/PLT - Find Exceptions ;12/3/07
- ;;4.0;PAID;**26,34,69,102,112,116**;Sep 21, 1995;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRSATPE ;HISC/REL-Find Exceptions ;12/08/05
+ ;;4.0;PAID;**26,34,69,102**;Sep 21, 1995
  K ER S (ECNT,FATAL)=0,X0=$G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),STAT=$P($G(^(10)),"^",1)
  N MLTIME S MLTIME=0
  S TC=$P(X0,"^",2) I 'TC S ER(1)=$P($T(ERTX+1),";;",2),FATAL=1 G EX
- ;
- ;ensure Normal Hrs = tour hrs for hourly employees
- I DAY=14 I '$$HRSMATCH(PPI,DFN) S FATAL=1,ERR=21 D ERR3640 G EX
- ;
  I "1 3 4"'[TC,STAT="" S ER(1)=$P($T(ERTX+2),";;",2),FATAL=1 G EX
- ;
- ;  Validate NAWS 36/40 nurse tours--can't certify if errors
- N NAWSERR S NAWSERR=0
- I DAY=7!(DAY=14),$$NAWS3640(DFN,PPI) D
- .  I $$SAT2DAY(DAY/7,DFN,PPI) D
- ..    S FATAL=1 S ERR=16 D ERR3640 S ERR=17 D ERR3640
- ..    S NAWSERR=1
- .  I $$THREE12(DAY/7,DFN,PPI) D
- ..    S FATAL=1 I 'NAWSERR S ERR=16 D ERR3640
- ..    S ERR=$S(DAY=7:19,1:20) D ERR3640
- I DAY=1,$$NAWS3640(DFN,PPI),$$CARRYOVR(DFN,PPI) D
- .    S FATAL=1 S ERR=16 D ERR3640 S ERR=18 D ERR3640
- ;
- S X2=$G(^PRST(458,PPI,"E",DFN,"D",DAY,2)) G:X2="" EX S X1=$G(^(1)),X4=$G(^(4)),K=$P($G(^(10)),U,4)
- ;check recess entire day having un-unavailable posted for all scheduled on-on call
- I $E($G(PRSENT),5),K=2,X2["^RS" D
- . F K=1:3 QUIT:$P(X1,U,K,999)=""  S Z=$P(X1,U,K+2) I Z,$P($G(^PRST(457.2,Z,0)),"^",2)="ON",X2'[($P(X1,U,K,K+1)_"^UN") S PRSWOC=$G(PRSWOC)_DAY_"," QUIT
- . I $G(PRSWOC)'[(DAY_",") F K=1:3 QUIT:$P(X4,U,K,999)=""  S Z=$P(X4,U,K+2) I Z,$P($G(^PRST(457.2,Z,0)),"^",2)="ON",X2'[($P(X4,U,K,K+1)_"^UN") S PRSWOC=$G(PRSWOC)_DAY_"," QUIT
- . QUIT
- ;
+ S X2=$G(^PRST(458,PPI,"E",DFN,"D",DAY,2)) G:X2="" EX S X1=$G(^(1)),X4=$G(^(4))
  K TM I X2["OT"!(X2["CT") D TM
- K T,TRS F K=1:3 Q:$P(X1,"^",K)=""  S Z=$P(X1,"^",K+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") D
+ K T F K=1:3 Q:$P(X1,"^",K)=""  S Z=$P(X1,"^",K+2) I $S('Z:1,1:$P($G(^PRST(457.2,Z,0)),"^",2)="RG") D
  .S X=$P(X1,"^",K,K+1) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V0
  .I Z1'="",$G(T(Z1))="*" K T(Z1) S T(Z2)="*" Q
@@ -40,26 +16,15 @@
  .S T(Z1)="",T(Z2)="*" Q
  ;
- ;find rs-type of time segments of trs array in x2 posted string
- I X2["^RS" F K=1:4:25 QUIT:$P(X2,U,K,999)=""  S X=$P(X2,"^",K,K+1) I "^"'[X,$P(X2,"^",K+2)="RS" D
- . S TT=$P(X2,"^",K+2) D CNV^PRSATIM S Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V1
- . I Z1'="",$G(TRS(Z1))="*" K TRS(Z1) S TRS(Z2)="*" QUIT
- . S TRS(Z1)="",TRS(Z2)="*"
- . QUIT
  ; Checks for Daily employees
  I "^"[$P(X2,"^",1,2) S TT=$P(X2,"^",3),K=1,DN=0,Y0="" G L0
  F K=1:4:25 S X=$P(X2,"^",K,K+1) I "^"'[X D
- . N Z3,Z4
- . S TT=$P(X2,"^",K+2)
- . D CNV^PRSATIM S Y0=Y,Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V1 S TIM=Z2-Z1/60
- . S Z3=Z1,Z4=Z2
- . I TT="ML" S MLTIME=MLTIME+TIM
- . S Z1=$O(T(Z1)) S:Z1'="" Z1=T(Z1)
- . S Z2=$O(T(Z2-1)) S:Z2'="" Z2=T(Z2)
- . ;trs=1 if absolute outside rs, 2 if absolute inside rs, 3 if overlap (in/outside) rs and inside tour of duty
- . ;if exception segment start/ending time outside tour of duty, reset z3 and z4
- . I Z1]""!(Z2]""),X2["^RS" S:Z1=""&(Z2="*") Z3=$O(T(Z3)) S:Z1="*"&(Z2="") Z4=$O(T(Z3)) S Z3=$O(TRS(Z3)) S:Z3]"" Z3=TRS(Z3) S Z4=$O(TRS(Z4-1)) S:Z4]"" Z4=TRS(Z4) S TRS=$S(Z3=""&(Z4=""):1,Z3="*"&(Z4="*"):2,1:3)
- . I TT="UN" D UN^PRSATPH QUIT
- . I "CT OT ON SB RG"[TT D OT QUIT
- . D LV QUIT
+ .S TT=$P(X2,"^",K+2)
+ .D CNV^PRSATIM S Y0=Y,Z1=$P(Y,"^",1),Z2=$P(Y,"^",2) D V1 S TIM=Z2-Z1/60
+ .I TT="ML" S MLTIME=MLTIME+TIM
+ .S Z1=$O(T(Z1)) S:Z1'="" Z1=T(Z1)
+ .S Z2=$O(T(Z2-1)) S:Z2'="" Z2=T(Z2)
+ .I TT="UN" D UN^PRSATPH Q
+ .I "CT OT ON SB RG"[TT D OT Q
+ .D LV Q
  ;
  ; Check for a minimum of 1 hour ML
@@ -95,6 +60,5 @@
  I TT="ON"&(X2["HX") Q
  ;I "OT CT"[TT,TIM'>1 Q
- ;none-leave hours are inside tour hours, but quit if inside rs hours
- QUIT:$G(TRS)=2!(TT="HW"&(X2["^RS"))  S ERR=6 QUIT
+ S ERR=6 Q
 TM ; Get OT,CT request,approve times
  S DTI=$P($G(^PRST(458,PPI,1)),"^",DAY),DA=0 Q:'DTI
@@ -108,13 +72,10 @@
  I TC=3!(TC=4) Q
  I TC=1,TT="HW" Q
- ;leave hours are (overlap) outside tour hours or (overlap) inside recess hours
- I ($G(TRS)'=1&(TT="HW")&$G(TRS)) QUIT
- I Z1'="*"!(Z2'="*")!($G(TRS)'=1&(TT'="RS")&$G(TRS)) S ERR=5,FATAL=1 D ERR
+ I Z1'="*"!(Z2'="*") S ERR=5,FATAL=1 D ERR
  ;
 L0 N REMARK S REMARK=$P(X2,"^",K+3)
  Q:REMARK&(REMARK'=15&(REMARK'=16))
  I "HX"[TT D HENCAP
- ;no leave request for non-leave hour and rs types
- QUIT:"RG CP NP HX HW TR TV RS"[TT
+ Q:"RG CP NP HX HW TR TV"[TT
  S DTI=$P($G(^PRST(458,PPI,1)),"^",DAY) Q:'DTI  S (DT1,DT2)=DTI
  I DN D D2 S:DN=2 DT1=DT2
@@ -142,59 +103,7 @@
  S ERR=15 D ERR Q  ; Holiday in current PP
  Q
-NAWS3640(PRSEMP,PPI) ; return true if NAWS 36/40 Nurse for this PPI
- N EMPNODE,PAYPLAN,DTYBASIS,NORMHRS,S8
- S S8=$G(^PRST(458,PPI,"E",PRSEMP,5))
- I S8'="",($E(S8,26,27)'=72!("KM"'[$E(S8,28))!($E(S8,29)'=1)) Q 0
- S EMPNODE=$G(^PRSPC(PRSEMP,0))
- S PAYPLAN=$P(EMPNODE,U,21)
- S DTYBASIS=$P(EMPNODE,U,10)
- S NORMHRS=$P(EMPNODE,U,16)
- Q "KM"[PAYPLAN&(DTYBASIS=1)&(NORMHRS=72)
-SAT2DAY(WK,PRSIEN,PPI) ;
- N HRS,SUNTRHRS,SAT2DAY,PRSD
- S SAT2DAY=0
- S PRSD=$S(WK=1:7,1:14)
- S SAT2DAY=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",2)
- I SAT2DAY>0 S SAT2DAY=$P($G(^PRST(457.1,SAT2DAY,0)),U,5)="Y"
- Q SAT2DAY
-CARRYOVR(PRSIEN,PPI) ; true if hours are coming in from last pp
- N PRIORSAT,SAT2DAY
- S SAT2DAY=0
- S PRIORSAT=$P($G(^PRST(458,PPI-1,"E",PRSIEN,"D",14,0)),U,2)
- I PRIORSAT>0 S SAT2DAY=$P($G(^PRST(457.1,PRIORSAT,0)),U,5)="Y"
- Q SAT2DAY
-THREE12(WK,PRSIEN,PPI) ;
- N PRSD,TOURDTY,COUNT,ST,EN
- S COUNT=0
- S ST=$S(WK=1:1,1:8),EN=$S(WK=1:7,1:14)
- F PRSD=ST:1:EN D
- . S TOURDTY=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",2)
- . I $P($G(^PRST(457.1,TOURDTY,0)),U,6)=12 S COUNT=COUNT+1
- I COUNT'=3 Q 1
- N HRS
- D TOURHRS^PRSARC07(.HRS,PPI,PRSIEN)
- Q:(HRS($S(WK=1:"W1",1:"W2"))'=36) 1
- Q 0
-HRSMATCH(PPI,DFN) ; Return true if hourly employee tour hrs '= 8B normal hrs
- N MATCH,HRS,NH,ENT,ENTPTR
- I $G(PPI)'>0!($G(DFN)'>0) Q 1
- S MATCH=1
- S NH=-1
- S ENTPTR=$P($G(^PRST(458,PPI,"E",DFN,0)),U,5)
- I ENTPTR'="" D
- .  S ENT=$P($G(^PRST(457.5,ENTPTR,1)),U)
- .  S NH=$E($G(^PRST(458,PPI,"E",DFN,5)),26,27)
- .  Q:NH="00"
- .  I +NH'>0 S NH=$P($G(^PRSPC(DFN,0)),U,50)
- I $G(ENT)="" D ^PRSAENT
- I $G(ENT)'="",$E(ENT)'="D",($E(ENT,1,2)'="0D"),$G(NH)'=112 D
- .  D TOURHRS^PRSARC07(.HRS,PPI,DFN)
- .  I ($G(HRS("W1"))+$G(HRS("W2")))'=+$G(NH) S MATCH=0
- Q MATCH
  ;
 ERR ; Set Error
  S ECNT=ECNT+1,ER(ECNT)=TT_$P($T(ERTX+ERR),";;",2)_"^"_$P(X2,"^",K) Q
-ERR3640 ; Set NAWS (36/40) Errors and errors not related to a single segment
- S ECNT=ECNT+1,ER(ECNT)=$P($T(ERTX+ERR),";;",2) Q
 ERTX ;;
 1 ;;No Tour Entered^
@@ -202,6 +111,6 @@
 3 ;; not Requested
 4 ;; Requested but not Approved
-5 ;; Posted outside of Tour Hours or within Recess Hours
-6 ;; Posted within Tour Hours or outside of Recess Hours
+5 ;; Posted outside of Tour Hours
+6 ;; Posted within Tour Hours
 7 ;; Posted exceeds Requested Hours
 8 ;; Requested but pending Supervisor Approval
@@ -213,8 +122,2 @@
 14 ;; The minimum charge for Military Leave is one hour
 15 ;; was encapsulated by non-pay
-16 ;;36/40 AWS tours require
-17 ;; -no 2 day tours on Sat
-18 ;; -no prior pp carryover
-19 ;; -3 12 hr tours/wk 1
-20 ;; -3 12 hr tours/wk 2
-21 ;;Normal/Tour hrs unequal
Index: FOIAVistA/tag/r/PAID-PRS/PRSAUDP.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSAUDP.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSAUDP.m	(revision 636)
@@ -1,13 +1,8 @@
-PRSAUDP ; WOIFO/DWA - Display Employee Pay Period Audit Data ;12/3/07
- ;;4.0;PAID;**116**;Sep 21, 1995;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRSAUDP ; HISC/JLS-Display Employee Pay Period Audit Data ;5/13/94  09:43
+ ;;4.0;PAID;;Sep 21, 1995
  ;called by PRSADP2
  D RET Q:QT
  S STATYPE=$P(^DD(458.1101,4,0),"^",3)
- S PG=PG+1,X=$G(^PRSPC(DFN,0)) W @IOF,!,?3,$P(X,U,1) S X=$P(X,U,9)
- I '$G(PRSTLV)!($G(PRSTLV)=1) W ?68,"XXX-XX-",$E(X,6,9)
- I $G(PRSTLV)=2!($G(PRSTLV)=3) W ?68,$E(X),"XX-XX-",$E(X,6,9)
- I $G(PRSTLV)=7 W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
- W !,?26,"Corrected  T&A  History",!!
+ S PG=PG+1,X=$G(^PRSPC(DFN,0)) W @IOF,!,?3,$P(X,U,1) S X=$P(X,U,9) W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9),!,?26,"Corrected  T&A  History",!!
 AUN S AUN=0 F  S AUN=$O(^PRST(458,PPI,"E",DFN,"X",AUN)) Q:AUN=""!(QT=1)  D B
  W @IOF
Index: FOIAVistA/tag/r/PAID-PRS/PRSDSERV.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSDSERV.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSDSERV.m	(revision 636)
@@ -1,7 +1,6 @@
-PRSDSERV ;WOIFO/MGD,PLT - PAID DOWNLOAD MESSAGE SERVER ;12/3/07
- ;;4.0;PAID;**6,78,82,116**;Sep 21, 1995;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
+PRSDSERV ;HISC/MGD-PAID DOWNLOAD MESSAGE SERVER ;09/13/2003
+ ;;4.0;PAID;**6,78,82**;Sep 21, 1995
  D NOW^%DTC S TIME=% S XMPOS=1 D REC^XMS3 G:XMER'=0 EXIT
- S LPE=$E(XMRG,1,7) I LPE'?1"**"2N1"PDH",LPE'="****PDH" G EXIT
+ G:$E(XMRG,1,7)'="****PDH" EXIT
  ; EMPCNT = # emp in this mail message
  ; SEQNUM = Mail message sequence number if more than one message
@@ -12,6 +11,4 @@
  I $D(^PRSD(450.12,"B",XMZ)) G EXIT
  S MTYPE=$S(TYPE="I":"Initial",TYPE="E":"Edit & Update",TYPE="P":"Payrun",TYPE="T":"Transfer",1:"")
- ; Set Lines Per Employee (LPE) for the correct interface
- S LPE=$E(LPE,3,4),LPE=$S(LPE?2N:+LPE,TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0)
  D REC^XMS3 G:XMER'=0 EXIT S STA=$E(XMRG,1,3) I STA'?3N G EXIT
  I TYPE="D" D ^PRSDDL G EXIT  ; Process Separation download
@@ -26,5 +23,6 @@
  S $P(^PRSD(450.12,+Y,0),U,3)="R",$P(^PRSD(450.12,+Y,0),U,4)=TIME
  S ^PRSD(450.12,"C",TYPE_"-"_DATE_"-"_STA_"-"_SEQNUM,+Y)=""
-SETPRS ;start employee record
+ ; Set Lines Per Employee (LPE) for the correct interface
+SETPRS S LPE=$S(TYPE="I":20,(TYPE="E")!(TYPE="T"):15,TYPE="P":9,1:0)
  S XMPOS=2 F A=1:1:EMPCNT D SSNLOOP Q:SSN=999999999
  I $D(^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM)) K ^XTMP("PRS","MNR",TYPE,DATE,STA,SEQNUM) Q
@@ -70,5 +68,5 @@
  Q
  ; Piece together the routine name and call the routine
-PROC S TMPIEN="" F  S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN=""  S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),RTNNUM=$P(TMPIEN,"-",3) S:$L(RTNNUM)=1 RTNNUM=0_RTNNUM S RTN="^PRSD"_RTYPE_RTNNUM D:$T(@RTN)]"" @RTN
+PROC S TMPIEN="" F  S TMPIEN=$O(^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN)) Q:TMPIEN=""  S RCD=^XTMP("PRS",SUB,DATE,TYPE,STA,SSN,TMPIEN),RTNNUM=$P(TMPIEN,"-",3) S:$L(RTNNUM)=1 RTNNUM=0_RTNNUM S RTN="^PRSD"_RTYPE_RTNNUM D @RTN
  Q
 PROC2 I TYPE="P",PP'="" D ^PRSDCOMP  ;Compute calculated fields
Index: FOIAVistA/tag/r/PAID-PRS/PRSPUT3.m
===================================================================
--- FOIAVistA/trunk/r/PAID-PRS/PRSPUT3.m	(revision 631)
+++ FOIAVistA/tag/r/PAID-PRS/PRSPUT3.m	(revision 636)
@@ -1,4 +1,4 @@
-PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;03/23/07
- ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54
+PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;06/15/05
+ ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
  ;;Per VHA Directive 2004-038, this routine should not be modified.
  ;
@@ -268,5 +268,5 @@
  S TCH1=$E(T,1,1)
  D E2^PRS8VW
- S CHKLN=$P($T(@(TCH1)+0^PRS8VW2),";;",2)
+ S CHKLN=$P($T(@(TCH1)+0^PRS8VW1),";;",2)
  F I=1:1:$L(CHKLN,"^") D  Q:FOUND
  .  S CHUNK=$P(CHKLN,U,I)
Index: FOIAVistA/tag/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m
===================================================================
--- FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m	(revision 631)
+++ FOIAVistA/tag/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m	(revision 636)
@@ -1,4 +1,4 @@
-QACVEMPX ; OAKOIFO/TKW - Return Person Data, called by RPC ;9/25/07  14:14
- ;;2.0;Patient Representative;**19,21**;07/25/1995;Build 5
+QACVEMPX ; Return Person Data using Value List Handler Pattern to update Patient Advocate PatsPerson table ;5/8/06  10:36
+ ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
 EN(PATSBY,LKUPVAL,PATSROWS,PATSFRM0,PATSFRM1)        ; Lookup Employee by Name, then
  ; Output XML formatted data from NEW PERSON file.
@@ -7,16 +7,13 @@
  ;         an array of Security Keys.
  ; PATSROWS=Number of rows to return in each call
- ; PATSFRM0=Employee Name value from previous call (empty on first call, pass by ref)
- ; PATSFRM1=Employee IEN from previous call (empty on first call, pass by ref)
+ ; PATSFRM0=Employee Name value from previous call (empty on first call)
+ ; PATSFRM1=Employee IEN from previous call (empty on first call)
  K ^TMP("DILIST",$J),^TMP("PatsPersonXml",$J)
- N STDNAME,ULASTNM,NAMECOMP,IENS,PIECE,OUTCNT,TAGLIST,FROM,PART,SRVIEN,MAILCODE,TITLE,SRVRSTA,PATSMORE,PATSERR,DIERR,I,J,X,Y
- ; If LKUPVAL exists, it contains an employee name, find partial matches.
- I $G(LKUPVAL)]"" D
- . S ULASTNM=$P(LKUPVAL,",")
- . D LOOKUP1
- . I (ULASTNM[" ")!(ULASTNM["'") D LOOKUP2
- . Q
- ; Else, it contains an array of Security Key values, find all
- ; holders of those keys.
+ N STDNAME,NAMECOMP,IENS,PIECE,OUTCNT,TAGLIST,FROM,PART,SRVIEN,MAILCODE,TITLE,SRVRSTA,PATSMORE,PATSERR,DIERR,I,J,X,Y
+ ; If LKUPVAL exists, it contains an employee name. Else, it is
+ ;  an array of Security Key values and we want to find all holders
+ ;  of those keys.
+ ; Standardize the name, parse out last name and first name.
+ I $G(LKUPVAL)]"" S STDNAME=LKUPVAL D BYNAME
  I $G(LKUPVAL)="" D
  . D EN^QACVKHLD(.LKUPVAL,PATSROWS,.PATSFRM0,.PATSFRM1)
@@ -37,57 +34,6 @@
  ;
  ;
-LOOKUP1 ; Use current routine to standardize the name (IA #3065)
- ; (name may contain spaces or apostrophes).
- S STDNAME=LKUPVAL
- I '$G(PATSROWS) S PATSROWS=10
- S PATSMORE=0
- I STDNAME["," S STDNAME=$$FORMAT^XLFNAME7(.STDNAME,1,35,,,,,1)
- E  S STDNAME=$$FORMAT^XLFNAME7(.STDNAME,1,35,,0,,1,1)
- ; If we've already found all matches to current standard, get out.
- N QOUT S QOUT=0
- I (ULASTNM[" ")!(ULASTNM["'") D  Q:QOUT
- . S X=$P($G(PATSFRM0),",")
- . Q:X=""
- . I (X[" ")!(X["'") Q
- . S QOUT=1 Q
- ; Get list of matching names.
- D GETLIST(STDNAME,PATSROWS,.PATSFRM0,.PATSFRM1,.PATSMORE,.FROM)
- Q
-LOOKUP2 ; Use old routine to standardize the name (no punctuation
- ; except hyphens).)
- ; Quit if the maximum number of names has been found.
- Q:PATSMORE
- ; Convert user input using old standardization routine
- S STDNAME=LKUPVAL
+BYNAME ; Standardize the name, parse out last name and first name. (IA #3065)
  D STDNAME^XLFNAME(.STDNAME,"FG")
- ; Find enough names to fill the list
- N NEWROWS
- S NEWROWS=PATSROWS-$P($G(^TMP("DILIST",$J,0)),"^")
- ; If list is already full, see whether there are more names
- ; using the old standardization, then quit.
- I NEWROWS'>0 D  Q
- . I $D(^VA(200,"B",STDNAME)) S NEWROWS=1
- . E  S X=$O(^VA(200,"B",STDNAME)) I $E(X,1,$L(STDNAME))=STDNAME S NEWROWS=1
- . I NEWROWS=1 S PATSMORE=1,FROM(1)=STDNAME,FROM(2)=""
- . Q
- ; Save off names found using current name standardization.
- K ^TMP("QACOLD",$J)
- I $D(^TMP("DILIST",$J)) D
- . M ^TMP("QACOLD",$J)=^TMP("DILIST",$J)
- . K ^TMP("QACOLD",$J,0) Q
- K ^TMP("DILIST",$J)
- ; Get new list of matching names.
- D GETLIST(STDNAME,NEWROWS,.PATSFRM0,.PATSFRM1,.PATSMORE,.FROM)
- ; Merge the two lists into ^TMP("DILIST",$J).
- S I=$O(^TMP("QACOLD",$J,PATSROWS+1),-1)
- I I D
- . S X=$P($G(^TMP("DILIST",$J,0)),"^")
- . I X F J=1:1:X I $D(^TMP("DILIST",$J,J,0)) S ^TMP("QACOLD",$J,(I+J),0)=^TMP("DILIST",$J,J,0) K ^TMP("DILIST",$J,J,0)
- . M ^TMP("DILIST",$J)=^TMP("QACOLD",$J)
- . S $P(^TMP("DILIST",$J,0),"^")=X+I
- . K ^TMP("QACOLD",$J)
- . Q
- Q 
-GETLIST(STDNAME,PATSROWS,PATSFRM0,PATSFRM1,PATSMORE,FROM) ; Get a list of names matching STDNAME
  N FIRST,LAST,LEN,SCR,CURRDT
  S LAST=$P(STDNAME,","),FIRST=$P(STDNAME,",",2,99)
@@ -101,4 +47,5 @@
  E  S FROM(1)=PATSFRM0,FROM(2)=$G(PATSFRM1)
  S PART(1)=LAST
+ I '$G(PATSROWS) S PATSROWS=10
  ; Return list of standard name pointer, title and mail code (IA #10060)
  D LIST^DIC(200,,"@;8;28","MP",PATSROWS,.FROM,.PART,"B",SCR)
@@ -121,19 +68,10 @@
  . S ^TMP("PatsPersonXml",$J,OUTCNT)="<PatsPerson>"
  . S IENS=$P(X,"^") Q:IENS=""  S IENS=IENS_","
- . ; NOTE: removes reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153)
- . S TITLE=$$SYMENC^MXMLUTL($E($P(X,"^",2),1,30))
- . S MAILCODE=$$SYMENC^MXMLUTL($E($P(X,"^",3),1,30))
+ . ; NOTE: does not remove reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153)
+ . S TITLE=$E($P(X,"^",2),1,30)
+ . S MAILCODE=$E($P(X,"^",3),1,30)
  . ; Get the individual name components and add them to the output (IA #3065)
- . K NAMECOMP
- . S NAMECOMP=$P($G(^VA(200,+IENS,0)),"^")
- . ; If name contains apostrophes or spaces, use current standardization
- . I ($P(NAMECOMP,",")["'")!($P(NAMECOMP,",")[" ") D
- .. S NAMECOMP=$$FORMAT^XLFNAME7(.NAMECOMP,1,35,,,,,2)
- .. S NAMECOMP=NAMECOMP("FAMILY")_"^"_NAMECOMP("GIVEN")_"^"_NAMECOMP("MIDDLE")_"^"_NAMECOMP("SUFFIX")
- .. Q
- . ; Else, use old standardization routine.
- . E  D
- .. K NAMECOMP S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS
- .. S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP,"S")
+ . K NAMECOMP S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS
+ . S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP,"S")
  . F J=1:1:6 D
  .. S OUTCNT=OUTCNT+1
Index: FOIAVistA/tag/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBUTL.m
===================================================================
--- FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBUTL.m	(revision 631)
+++ FOIAVistA/tag/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBUTL.m	(revision 636)
@@ -1,4 +1,4 @@
 PXBUTL ;ISL/JVS,ESW - UTILITIES FOR PROMPTS ; 10/31/02 12:13pm
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**32,108**;Aug 12, 1996
+ ;;1.0;PCE PATIENT CARE ENCOUNTER;**32,108**;Aug 12, 1996;Build 1
  ;
  ;
Index: FOIAVistA/tag/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXTTU1.m
===================================================================
--- FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXTTU1.m	(revision 631)
+++ FOIAVistA/tag/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXTTU1.m	(revision 636)
@@ -1,4 +1,20 @@
-PXTTU1 ;ISL/JVS/ESW - Utility Routine-calls from input transforms ;5/20/96  17:14
- ;;1.0;PCE PATIENT CARE ENCOUNTER;**106**;Aug 12, 1996
+PXTTU1 ;ISL/JVS/ESW - Utility Routine-calls from input transforms ;10/10/06  19:07
+ ;;1.0;PCE PATIENT CARE ENCOUNTER;**106,167**;Aug 12, 1996;Build 22
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  Q
  ; This routines purpose is to hold utilities used by the supporting
@@ -24,5 +40,5 @@
  Q
  ;
-GETSITE S PXTDUZ=+$P($$SITE^VASITE,U,3)
+GETSITE S PXTDUZ=$P($$SITE^VASITE,U,3) S:$G(DUZ("AG"))="V" PXTDUZ=+PXTDUZ
  I $L(PXTDUZ)'=3 W !,"Primary site is not 3 character station number! See IRM for setup." Q
  Q
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUCP.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUCP.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUCP.m	(revision 636)
@@ -1,9 +1,8 @@
-PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ; 06/08/07
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
+PSUCP ;BIR/TJH,PDW - PBM CONTROL POINT ;25 AUG 1998
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ; Reference to File #4    supported by DBIA 10090
  ; Reference to File #4.3  supported by DBIA 10091
  ; Reference to File #40.8 supported by DBIA 2438
  ; Reference to File #59.7 supported by DBIA 2854
- ; move CLEANUP^PSUHL from PSURT1, delete calls to PSUCP3 (PSU*4*12)
 MANUAL ; entry point for manual option
  S PSUALERT=0 D MANUAL^PSUALERT
@@ -18,5 +17,5 @@
  .S DIR("A")="Do you wish to continue"
  .D ^DIR
- D CLEANUP^PSUHL
+ D ^PSUCP3
  S PSUJOB=$J_"_"_$P($H,",",2)
  S ^XTMP("PSUMANL")=""
@@ -37,8 +36,8 @@
  S PSUALERT=0 D AUTO^PSUALERT
  I PSUALERT K PSUALERT Q
- I $D(^XTMP("PSU","RUNNING")) D  Q
+ I $G(^XTMP("PSU","RUNNING")) D  Q
  .S XQA(DUZ)="",XQA("G.PSU PBM")="",XQMSG="An ERROR has occurred. Please contact IRM for assistance."
  .S XQAID="PSU",XQAFLG="D" D SETUP^XQALERT
- D CLEANUP^PSUHL
+ D ^PSUCP3         ;Clear trash globals
  S PSUJOB=$J_"_"_$P($H,",",2)
  S ^XTMP("PSU_"_PSUJOB,"PSUFLAG1")=""   ;flag for mail patient summary reports
@@ -67,5 +66,5 @@
  D ^PSUDBQUE
  K PSUALERT,XQA,XQAID,XQAFLG,XQA,ZTSK
-AUTOQ Q  ; exit from AUTO
+AUTOQ D EXIT Q  ; exit from AUTO
  ;
 RUN ; run each selected module
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM1.m	(revision 636)
@@ -1,4 +1,4 @@
 PSUDEM1 ;BIR/DAM - Patient Demographics Extract ; 20 DEC 2001
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;
  ;DBIA's
@@ -38,6 +38,5 @@
  ;information ONLY on new or updated patient.
  ;
- ; *** PSU*4.0*12 - BAJ -- added QUIT if NULL
- F  S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT=""  Q:PSUSDT>PSUEDT  D
+ F  S PSUSDT=$O(^PSUDEM("B",PSUSDT)) Q:PSUSDT>PSUEDT  D
  . S I=""
  . S I=$O(^PSUDEM("B",PSUSDT,I)) Q:I=""
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUDEM4.m	(revision 636)
@@ -1,4 +1,4 @@
-PSUDEM4 ;BIR/DAM - Provider Extract ; 4/26/07 4:38pm
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8,12**;MARCH, 2005;Build 19
+PSUDEM4 ;BIR/DAM - Provider Extract ; 7/21/06 2:27pm
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;**8**;MARCH, 2005
  ;
  ;DBIA'S
@@ -102,12 +102,8 @@
 CLASS ;Find provider class
  ;
- I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)="" Q
+ I '$D(PSUCLP) S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
  I PSUCLP="" S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=""
  I PSUCLP'="" D
- .N PSUA
- .S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,2)
- .I PSUA']"" S PSUA=$P($G(^DIC(7,PSUCLP,0)),U,1)
- .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=PSUA  ;Prov class
- .K PSUA
+ .S $P(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIEN),U,5)=$P($G(^DIC(7,PSUCLP,0)),U,2)  ;Prov class
  Q
  ;
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSULRHL1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 8/1/07 11:26am
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3,11**;MARCH, 2005;Build 8
+PSULRHL1 ;HCIOFO/BH/RDC - Process real time HL7 Lab messages ; 5/15/04 3:10pm
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;**3**;MARCH, 2005
  ;
  ; DBIA 3565 to subscribe to the LR7O ALL EVSEND RESULTS protocol
@@ -156,5 +156,4 @@
  S LABS=$P(REC,PSUHLFS,4)
  S LR60=$P(LABS,"^",4)
- I LR60']"" Q
  S LRDN=$G(^LAB(60,LR60,0))
  S LRDN=$P($P(LRDN,"^",5),";",2)   ;  DBIA 91 for data name
@@ -162,5 +161,4 @@
  ; Make the call to LRRPU to get the LOINC code for this test
  ;
- I LRDN']"" Q
  S RES=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,LRDN,LR60,1)
  ;
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUMAP0.m	(revision 636)
@@ -1,4 +1,4 @@
-PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 4/12/07 2:12pm
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
+PSUMAP0 ;BHM/PDW-MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 9SEP2003
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;
  ;DBIA's
@@ -51,6 +51,5 @@
  ..K PJJ,XBEG,XEND
  .S PSUMOD(X1)=""
- ; modified to fix <UNDEFINED> PSU*3*12 BAJ
- S X="",ERC=0 F  S X=$O(PSUMOD(X)) Q:X=""  I '$D(PSUA(X)) S ERC=1 Q
+ S (X,ERC)=0 F  S X=$O(PSUMOD(X)) Q:X=""  I '$D(PSUA(X)) S ERC=1 Q
  I ERC W !!,"<INVALID CHOICE - ",X,", TRY AGAIN>",$C(7) G MODP
  I '$D(PSUMOD) W !!,"No choices were made." K DIR S DIR(0)="E",DIR("A")="EXITING" D ^DIR G EXIT
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOPAM.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOPAM.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUOPAM.m	(revision 636)
@@ -1,4 +1,4 @@
-PSUOPAM ;BIR/DAM - PSU PBM Outpatient AMIS Pharmacy Data Collection; March 2004 ; 1/11/08 11:46am
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3
+PSUOPAM ;BIR/DAM - PSU PBM Outpatient AMIS Pharmacy Data Collection; March 2004
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;
  ;DBIA's
@@ -20,6 +20,5 @@
 CO ;Copay status: found in file (#52), field (#105)
  ;
- ;PSU*4*13 Corrected to show the COPAY.
- S PSUCO=$P($G(^TMP("PSOR",$J,PSURXIEN,"IB")),U,1)
+ S PSUCO=$P($G(^TMP("PSOR",$J,PSURXIEN,"IB",0)),U,1)
  I $G(PSUCO) S PSUCOPAY="Y"
  I '$G(PSUCO) S PSUCOPAY="N"
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUPR2.m	(revision 636)
@@ -1,4 +1,4 @@
-PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ; 4/1/08 4:09pm
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**13**;MARCH, 2005;Build 3
+PSUPR2 ;BIR/PDW - Procurement extract from file 58.811 ;20 AUG 1999
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;DBIAs
  ; Reference to file #58.811 supported by DBIA 2521
@@ -127,9 +127,7 @@
  I '$D(PSUADJ),'PSUIT(9999) S PSUIT(9999)="" ; per Lina
  ;
- ;PSU*4*13 Comment out To prevent XINDEX from complaining about
- ; ^PSUPR7 (CoreFLS remnance)
  ;Create "RECORDS" global for CoreFLS data
- ;I $D(PSUFLSFG) S PSUA="" D
- ;.F  S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA=""  D SIMPL^PSUPR7
+ I $D(PSUFLSFG) S PSUA="" D
+ .F  S PSUA=$O(^XTMP(PSUPRSUB,"PSUFLS",PSUA)) Q:PSUA=""  D SIMPL^PSUPR7
  ;
  ;   Construct record and store into ^XTMP(PSUPRSUB,"RECORDS",PSUDIV,LC)
@@ -231,7 +229,6 @@
  .S PSUDA=0
  .F  S PSUDA=$O(MAPLOC(PSUDA)) Q:PSUDA=""  D
- ..;PSU*4*13 Correct Problm DA Pharm Report
- ..I $G(MAPLOC(PSUDA,.02))'="" K DAPH(PSUDA)
- ..I $G(MAPLOC(PSUDA,.03))'="" K DAPH(PSUDA)
+ ..I $G(MAPLOC(PSUDA,.02))'="" K NAOU(PSUDA)
+ ..I $G(MAPLOC(PSUDA,.03))'="" K NAOU(PSUDA)
  M ^XTMP(PSUARSUB,"DAPH")=DAPH      ;only unmapped DA PHARM locations.
  Q
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSURT1.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSURT1.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSURT1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSURT1 ;BIR/RDC - PATIENT DEMOGRAPHIC RETRANSMITION; APR 2, 2007 ; 4/2/07 11:01am
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
+PSURT1 ;BIR/RDC - PATIENT DEMOGRAPHIC RETRANSMITION; 31 MAR 2004
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;
  ; THIS PROGRAM WILL ALLOW THE RETRANSMITION OF THE PATIENT
@@ -9,5 +9,5 @@
  NEW P,SDT,EDT,WHEN,NOGOOD,TMON,RMONTH,PMON,SMON,EMON,RTYPE,SRANGE,ERANGE
  S P=""
- ; move call to CLEANUP^PSUHL to routine PSUCP (PSU*4*12) 
+ D CLEANUP^PSUHL
  S SDT=$O(^PSUDEM("B",P))
  I 'SDT W !,"NO DATA AVAILABLE - NOTIFY YOUR SUPERVISOR" Q
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM1.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM1.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUSUM1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSUSUM1 ;BIR/DAM - Summary Report for Provider Extract ; 2/23/07 2:18pm
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**12**;MARCH, 2005;Build 19
+PSUSUM1 ;BIR/DAM - Summary Report for Provider Extract ; 20 DEC 2001
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;
  ; No DBIA's required.
@@ -55,5 +55,4 @@
  S PSUIP=0
  F  S PSUIP=$O(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)) Q:PSUIP=""  Q:PSUIP["U"  D
- .I $P($G(^VA(200,PSUIP,"PS")),"^",6)=4 Q  ; Exclude if the provider type is "FEE BASIS" (PSU*4*12)
  .S PSUSSN3=$E($P($G(^XTMP("PSU_"_PSUJOB,"PSUPROV",PSUIP)),U,3),6,9)
  .I PSUSSN3="" S PSUSSN3="????",PSUMIS="SSN" D NAM             ;No SSN
Index: FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUVIT1.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUVIT1.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_BENEFITS_MANAGEMENT-PSU/PSUVIT1.m	(revision 636)
@@ -1,4 +1,4 @@
-PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003 ; 10/9/07 7:03am
- ;;4.0;PHARMACY BENEFITS MANAGEMENT;**11**;MARCH, 2005;Build 8
+PSUVIT1 ;BIR/RDC - VITALS & IMMUNIZATION EXTRACT; 24 DEC 2003
+ ;;4.0;PHARMACY BENEFITS MANAGEMENT;;MARCH, 2005
  ;
  ;DBIA's
@@ -72,5 +72,4 @@
  N PSURTYPE,PSUSSN,PSUICN,PSUVTYPE,PSUVRATE,PSUVUNIT
  N Z,QQ,PSUVQ1,PSUVQ2,PSUVQ3,PSUVQ4,PSUVLIST,PSUVMSG
- N PSULN,PSUTXT
  ;
  S PSUVLIST="""BLOOD PRESSURE"",""HEIGHT"",""WEIGHT"",""PAIN"",""PULSE"",""PULSE OXIMETRY"""
@@ -78,9 +77,4 @@
  ;                          ** Loop through date index for valid dates **
  S PSUDATE=SDATE
- ;PSU*4*11 Added null ptr notification.
- S PSUTXT(1)="The following IEN(s) have a null pointer in the PATIENT (#2) field of"
- S PSUTXT(2)="the GMRV VITAL MEASUREMENT file (#120.5).  Please notify your IRM and"
- S PSUTXT(3)="submit a remedy ticket for help in evaluating the record."
- S PSULN=3
  F  S PSUDATE=$O(^GMR(120.5,"B",PSUDATE)) Q:PSUDATE>EDATE!('PSUDATE)  D
  . S PSUV=""                      ; ** loop thru vitals for each date **
@@ -89,7 +83,4 @@
  .. S PSUVREC=$G(^GMR(120.5,PSUV,0)) Q:'PSUVREC
  .. S PSUPTPTR=$P(PSUVREC,U,2)    ; ** point to PATIENT **
- .. I PSUPTPTR="" D  Q            ; ** quit if no patient pointer **
- ... S PSULN=PSULN+1
- ... S PSUTXT(PSULN)=PSUV
  .. Q:$G(^DPT(PSUPTPTR,0))=""     ; ** quit if no patient record **
  .. S PSUPTREC=^DPT(PSUPTPTR,0)   ; ** get patient record **
@@ -123,10 +114,4 @@
  .. ; ** S PSUVTMP(PSUSSN,PSUVTYPE)=PSUVMSG
  .. S ^XTMP("PSU_"_PSUJOB,"PSUVI","TMP",PSUSSN,PSUVTYPE)=PSUVMSG
- ;PSU*4*11 Send null ptr notifications to PBM group.
- I PSULN>3 D
- . S XMTEXT="PSUTXT(",XMY("G.PSU PBM")=""
- . S XMSUB="** PBM vitals extract detected null patient pointer(s) **"
- . S XMDUZ="Pharmacy Benefits Management Package"
- . N DIFROM D ^XMD
  Q
  ;               ** end of vital extract **
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDDUT2.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDDUT2.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDDUT2.m	(revision 636)
@@ -1,4 +1,4 @@
-PSSDDUT2 ;BIR/LDT - Pharmacy Data Management DD Utility ; 8/21/07 8:43am
- ;;1.0; PHARMACY DATA MANAGEMENT; **3,21,61,81,95,127,126**;9/30/97;Build 11
+PSSDDUT2 ;BIR/LDT - Pharmacy Data Management DD Utility ;10/30/97 9:41
+ ;;1.0; PHARMACY DATA MANAGEMENT; **3,21,61,81,95,127**;9/30/97;Build 41
  ;
  ;Reference to ^DIC(42 supported by DBIA #10039
@@ -33,33 +33,9 @@
  ;;R          RESTRICTED ITEMS
  ;;S          SUPPLY ITEMS
- ;;B          ALLOW REFILL (SCH. 3, 4, 5 ONLY)
+ ;;B          ALLOW REFILL (SCH. 3, 4, 5 NARCOTICS ONLY)
  ;;W          NOT RENEWABLE
  ;;F          NON REFILLABLE
  ;;E          ELECTRONICALLY BILLABLE
  ;;
-DEATBL ; More Help regarding DEA Codes
- K PSSHLP
- F II=1:1 Q:$P($T(TBL+II),";",3)=""  S PSSHLP(II)=$P($T(TBL+II),";",3,99)
- S PSSHLP(1,"F")="!!" D WRITE
- ;
-TBL K II Q
- ;;          DEA CODE TABLE
- ;; CODE   ALLOW RENEWS ALLOW REFILLS
- ;; 1            NO           NO
- ;; 2            NO           NO
- ;; 2A           NO           NO 
- ;; 3            YES          YES
- ;; 3A           YES          NO
- ;; 3AB          YES          YES
- ;; 4            YES          YES
- ;; 4A           YES          NO
- ;; 4AB          YES          YES
- ;; 5            YES          YES
- ;; 5A           YES          NO
- ;; 5AB          YES          YES
- ;; ADDING W TO A SCHED. 3,4,OR 5 CODE DISALLOWS RENEWS.
- ;; ADDING F TO A SCHED. 3,4,OR 5 CODE DISALLOWS REFILLS
- ;; IF A CODE IS NOT LISTED IN THE ABOVE TABLE
- ;; IT HAS NO EFFECT ON RENEW OR REFILL
 SIG ;checks SIG for RXs (Replaces SIG^PSOHELP)
  I $E(X)=" " D EN^DDIOL("Leading spaces are not allowed in the SIG! ","","$C(7),!") K X Q
@@ -108,6 +84,5 @@
 EDIT ;INPUT XFORM FOR DEA FIELD IN DRUG FILE (Replaces EDIT^PSODEA)
  I X["F",X["B" D EN^DDIOL("Inappropriate F designation!","","$C(7),!") K X Q
- ;;DEA CHANGE PSS*1*126
- I X["B",(+X<3) D EN^DDIOL("The B designation is only valid for schedule 3, 4, 5 !","","$C(7),!") K X Q
+ I X["B",(+X<3!(X'["A")) D EN^DDIOL("The B designation is only valid for schedule 3, 4, 5 narcotics !","","$C(7),!") K X Q
  I X["A"&(X["C"),+X=2!(+X=3) D EN^DDIOL("The A & C designation is not valid for schedule 2 or 3 narcotics !","","$C(7),!") K X Q
  I $E(X)=1,X[2!(X[3)!(X[4)!(X[5) D EN^DDIOL("It contains other inappropriate schedule 2-5 narcotics!","","$C(7),!") K X Q
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDOSRP.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDOSRP.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDOSRP.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSDOSRP ;BIR/RTR-Dosage review report ;03/24/00
+PSSDOSRP ;BIR/RTR-Dosage review report ; 8/16/05 3:44pm
  ;;1.0;PHARMACY DATA MANAGEMENT;**34,38,49**;9/30/97
  ;Reference to ^PS(50.607 supported by DBIA 2221
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSHLU.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSHLU.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSHLU.m	(revision 636)
@@ -1,4 +1,4 @@
 PSSHLU ;BIR/RLW-UTILITIES USED IN BUILDING HL7 SEGMENTS ;11/14/96
- ;;1.0;PHARMACY DATA MANAGEMENT;**38,124,132**;9/30/97;Build 1
+ ;;1.0;PHARMACY DATA MANAGEMENT;**38**;9/30/97
  ;
 INIT ; set up HL7 application variables
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR ; DRIVER FOR COMPILED XREFS FOR FILE #55 ; 12/12/07
+PSSJXR ; DRIVER FOR COMPILED XREFS FOR FILE #55 ; 01/17/08
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR1.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR1.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR1.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR1 ; COMPILED XREF FOR FILE #55 ; 12/12/07
+PSSJXR1 ; COMPILED XREF FOR FILE #55 ; 01/17/08
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR10.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR10.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR10.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR10 ; COMPILED XREF FOR FILE #55.051 ; 12/12/07
+PSSJXR10 ; COMPILED XREF FOR FILE #55.051 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR11.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR11.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR11.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR11 ; COMPILED XREF FOR FILE #55.0611 ; 12/12/07
+PSSJXR11 ; COMPILED XREF FOR FILE #55.0611 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR12.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR12.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR12.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR12 ; COMPILED XREF FOR FILE #55.07 ; 12/12/07
+PSSJXR12 ; COMPILED XREF FOR FILE #55.07 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR13.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR13.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR13.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR13 ; COMPILED XREF FOR FILE #55.09 ; 12/12/07
+PSSJXR13 ; COMPILED XREF FOR FILE #55.09 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR14.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR14.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR14.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR14 ; COMPILED XREF FOR FILE #55.11 ; 12/12/07
+PSSJXR14 ; COMPILED XREF FOR FILE #55.11 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR15.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR15.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR15.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR15 ; COMPILED XREF FOR FILE #55.1138 ; 12/12/07
+PSSJXR15 ; COMPILED XREF FOR FILE #55.1138 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR16.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR16.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR16.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR16 ; COMPILED XREF FOR FILE #55.6114 ; 12/12/07
+PSSJXR16 ; COMPILED XREF FOR FILE #55.6114 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR17.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR17.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR17.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR17 ; COMPILED XREF FOR FILE #55 ; 12/12/07
+PSSJXR17 ; COMPILED XREF FOR FILE #55 ; 01/17/08
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR18.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR18.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR18.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR18 ; COMPILED XREF FOR FILE #55.01 ; 12/12/07
+PSSJXR18 ; COMPILED XREF FOR FILE #55.01 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
@@ -63,5 +63,18 @@
  S X=$P(DIKZ(4),U,10)
  I X'="" K:X ^PS(55,"ANIV",DA(1),DA) S:'X ^PS(55,"ANIV",DA(1),DA)=""
-CR1 S DIXR=415
+CR1 S DIXR=481
+ K X
+ S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
+ S X(1)=$P(DIKZ(0),U,2)
+ S X(2)=$P(DIKZ(0),U,3)
+ S X=$G(X(1))
+ I $G(X(1))]"",$G(X(2))]"" D
+ . K X1,X2 M X1=X,X2=X
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=$$PATCH^XPDUTL("PXRM*1.5*12")
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . D SPSPA^PSJXRFS(.X,.DA,"IV")
+CR2 S DIXR=493
  K X
  S DIKZ(.2)=$G(^PS(55,DA(1),"IV",DA,.2))
@@ -77,18 +90,5 @@
  . Q:'DIKCOND
  . S ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"V")=""
-CR2 S DIXR=466
- K X
- S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
- S X(1)=$P(DIKZ(0),U,2)
- S X(2)=$P(DIKZ(0),U,3)
- S X=$G(X(1))
- I $G(X(1))]"",$G(X(2))]"" D
- . K X1,X2 M X1=X,X2=X
- . N DIKXARR M DIKXARR=X S DIKCOND=1
- . S X=$$PATCH^XPDUTL("PXRM*1.5*12")
- . S DIKCOND=$G(X) K X M X=DIKXARR
- . Q:'DIKCOND
- . D SPSPA^PSJXRFS(.X,.DA,"IV")
-CR3 S DIXR=498
+CR3 S DIXR=494
  K X
  S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
@@ -100,5 +100,5 @@
  . K X1,X2 M X1=X,X2=X
  . S ^PS(55,"AIVC",$E(X(1),1,20),$E(X(2),1,20),DA(1),DA)=""
-CR4 S DIXR=500
+CR4 S DIXR=496
  K X
  S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR19.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR19.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR19.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR19 ; COMPILED XREF FOR FILE #55.0105 ; 12/12/07
+PSSJXR19 ; COMPILED XREF FOR FILE #55.0105 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR2.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR2.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR2.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR2 ; COMPILED XREF FOR FILE #55.01 ; 12/12/07
+PSSJXR2 ; COMPILED XREF FOR FILE #55.01 ; 01/17/08
  ; 
  S DA(1)=DA S DA=0
@@ -63,21 +63,6 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PS(55,DA(1),"IV","B",$E(X,1,30),DA)
-CR1 S DIXR=415
+CR1 S DIXR=481
  K X
- S DIKZ(.2)=$G(^PS(55,DA(1),"IV",DA,.2))
- S X(1)=$P(DIKZ(.2),U,8)
- S X(2)=$P(DIKZ(0),U,21)
- S X=$G(X(1))
- I $G(X(1))]"",$G(X(2))]"" D
- . K X1,X2 M X1=X,X2=X
- . S:$D(DIKIL) (X2,X2(1),X2(2))=""
- . N DIKXARR M DIKXARR=X S DIKCOND=1
- . S X=1
- . S DIKCOND=$G(X) K X M X=DIKXARR
- . Q:'DIKCOND
- . K ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"V")
-CR2 S DIXR=466
- K X
- S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
  S X(1)=$P(DIKZ(0),U,2)
  S X(2)=$P(DIKZ(0),U,3)
@@ -91,5 +76,20 @@
  . Q:'DIKCOND
  . D KPSPA^PSJXRFK(.X,.DA,"IV")
-CR3 S DIXR=498
+CR2 S DIXR=493
+ K X
+ S DIKZ(.2)=$G(^PS(55,DA(1),"IV",DA,.2))
+ S X(1)=$P(DIKZ(.2),U,8)
+ S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
+ S X(2)=$P(DIKZ(0),U,21)
+ S X=$G(X(1))
+ I $G(X(1))]"",$G(X(2))]"" D
+ . K X1,X2 M X1=X,X2=X
+ . S:$D(DIKIL) (X2,X2(1),X2(2))=""
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=1
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . K ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"V")
+CR3 S DIXR=494
  K X
  S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
@@ -102,5 +102,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . K ^PS(55,"AIVC",$E(X(1),1,20),$E(X(2),1,20),DA(1),DA)
-CR4 S DIXR=500
+CR4 S DIXR=496
  K X
  S DIKZ(0)=$G(^PS(55,DA(1),"IV",DA,0))
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR20.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR20.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR20.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR20 ; COMPILED XREF FOR FILE #55.0108 ; 12/12/07
+PSSJXR20 ; COMPILED XREF FOR FILE #55.0108 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR21.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR21.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR21.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR21 ; COMPILED XREF FOR FILE #55.03 ; 12/12/07
+PSSJXR21 ; COMPILED XREF FOR FILE #55.03 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR22.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR22.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR22.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR22 ; COMPILED XREF FOR FILE #55.05 ; 12/12/07
+PSSJXR22 ; COMPILED XREF FOR FILE #55.05 ; 01/17/08
  ; 
  S DA=0
@@ -14,5 +14,5 @@
  S X=$P(DIKZ(0),U,10)
  I X'="" S ^PS(55,"ADCDT",$E(X,1,30),DA(1),DA)=""
-CR1 S DIXR=464
+CR1 S DIXR=479
  K X
  S X(1)=$P(DIKZ(0),U,1)
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR23.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR23.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR23.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR23 ; COMPILED XREF FOR FILE #55.06 ; 12/12/07
+PSSJXR23 ; COMPILED XREF FOR FILE #55.06 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR24.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR24.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR24.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR24 ; COMPILED XREF FOR FILE #55.02 ; 12/12/07
+PSSJXR24 ; COMPILED XREF FOR FILE #55.02 ; 01/17/08
  ; 
  I X'="" D
@@ -48,18 +48,5 @@
  S X=$P(DIKZ(0),U,27)
  I X'="" I '$D(DIU(0)) D:$D(PSGAL(107)) KILL^PSGAL5:PSGAL(107)=X K PSGAL
-CR1 S DIXR=414
- K X
- S DIKZ(.2)=$G(^PS(55,DA(1),5,DA,.2))
- S X(1)=$P(DIKZ(.2),U,8)
- S X(2)=$P(DIKZ(0),U,21)
- S X=$G(X(1))
- I $G(X(1))]"",$G(X(2))]"" D
- . K X1,X2 M X1=X,X2=X
- . N DIKXARR M DIKXARR=X S DIKCOND=1
- . S X=1
- . S DIKCOND=$G(X) K X M X=DIKXARR
- . Q:'DIKCOND
- . S ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"U")=""
-CR2 S DIXR=465
+CR1 S DIXR=480
  K X
  S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
@@ -74,5 +61,19 @@
  . Q:'DIKCOND
  . D SPSPA^PSJXRFS(.X,.DA,"UD")
-CR3 S DIXR=499
+CR2 S DIXR=492
+ K X
+ S DIKZ(.2)=$G(^PS(55,DA(1),5,DA,.2))
+ S X(1)=$P(DIKZ(.2),U,8)
+ S DIKZ(0)=$G(^PS(55,DA(1),5,DA,0))
+ S X(2)=$P(DIKZ(0),U,21)
+ S X=$G(X(1))
+ I $G(X(1))]"",$G(X(2))]"" D
+ . K X1,X2 M X1=X,X2=X
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=1
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . S ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"U")=""
+CR3 S DIXR=495
  K X
  S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
@@ -84,5 +85,5 @@
  . K X1,X2 M X1=X,X2=X
  . S ^PS(55,"AUDC",$E(X(1),1,20),$E(X(2),1,20),DA(1),DA)=""
-CR4 S DIXR=501
+CR4 S DIXR=497
  K X
  S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR25.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR25.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR25.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR25 ; COMPILED XREF FOR FILE #55.02 ; 12/12/07
+PSSJXR25 ; COMPILED XREF FOR FILE #55.02 ; 01/17/08
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR26.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR26.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR26.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR26 ; COMPILED XREF FOR FILE #55.051 ; 12/12/07
+PSSJXR26 ; COMPILED XREF FOR FILE #55.051 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR27.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR27.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR27.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR27 ; COMPILED XREF FOR FILE #55.0611 ; 12/12/07
+PSSJXR27 ; COMPILED XREF FOR FILE #55.0611 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR28.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR28.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR28.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR28 ; COMPILED XREF FOR FILE #55.07 ; 12/12/07
+PSSJXR28 ; COMPILED XREF FOR FILE #55.07 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR29.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR29.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR29.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR29 ; COMPILED XREF FOR FILE #55.09 ; 12/12/07
+PSSJXR29 ; COMPILED XREF FOR FILE #55.09 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR3.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR3.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR3.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR3 ; COMPILED XREF FOR FILE #55.0105 ; 12/12/07
+PSSJXR3 ; COMPILED XREF FOR FILE #55.0105 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR30.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR30.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR30.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR30 ; COMPILED XREF FOR FILE #55.11 ; 12/12/07
+PSSJXR30 ; COMPILED XREF FOR FILE #55.11 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR31.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR31.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR31.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR31 ; COMPILED XREF FOR FILE #55.1138 ; 12/12/07
+PSSJXR31 ; COMPILED XREF FOR FILE #55.1138 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR32.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR32.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR32.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR32 ; COMPILED XREF FOR FILE #55.6114 ; 12/12/07
+PSSJXR32 ; COMPILED XREF FOR FILE #55.6114 ; 01/17/08
  ; 
  S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR4.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR4.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR4.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR4 ; COMPILED XREF FOR FILE #55.0108 ; 12/12/07
+PSSJXR4 ; COMPILED XREF FOR FILE #55.0108 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR5.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR5.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR5.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR5 ; COMPILED XREF FOR FILE #55.03 ; 12/12/07
+PSSJXR5 ; COMPILED XREF FOR FILE #55.03 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR6.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR6.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR6.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR6 ; COMPILED XREF FOR FILE #55.05 ; 12/12/07
+PSSJXR6 ; COMPILED XREF FOR FILE #55.05 ; 01/17/08
  ; 
  S DA=0
@@ -14,5 +14,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PS(55,DA(1),"NVA","B",$E(X,1,30),DA)
-CR1 S DIXR=464
+CR1 S DIXR=479
  K X
  S X(1)=$P(DIKZ(0),U,1)
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR7.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR7.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR7.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR7 ; COMPILED XREF FOR FILE #55.06 ; 12/12/07
+PSSJXR7 ; COMPILED XREF FOR FILE #55.06 ; 01/17/08
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR8.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR8.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR8.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR8 ; COMPILED XREF FOR FILE #55.06 ; 12/12/07
+PSSJXR8 ; COMPILED XREF FOR FILE #55.06 ; 01/17/08
  ; 
  S X=$P(DIKZ(6.5),U,1)
@@ -32,21 +32,6 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^PS(55,"ANV",DA(1),DA)
-CR1 S DIXR=414
+CR1 S DIXR=480
  K X
- S DIKZ(.2)=$G(^PS(55,DA(1),5,DA,.2))
- S X(1)=$P(DIKZ(.2),U,8)
- S X(2)=$P(DIKZ(0),U,21)
- S X=$G(X(1))
- I $G(X(1))]"",$G(X(2))]"" D
- . K X1,X2 M X1=X,X2=X
- . S:$D(DIKIL) (X2,X2(1),X2(2))=""
- . N DIKXARR M DIKXARR=X S DIKCOND=1
- . S X=1
- . S DIKCOND=$G(X) K X M X=DIKXARR
- . Q:'DIKCOND
- . K ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"U")
-CR2 S DIXR=465
- K X
- S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
  S X(1)=$P(DIKZ(2),U,2)
  S X(2)=$P(DIKZ(2),U,4)
@@ -60,5 +45,20 @@
  . Q:'DIKCOND
  . D KPSPA^PSJXRFK(.X,.DA,"UD")
-CR3 S DIXR=499
+CR2 S DIXR=492
+ K X
+ S DIKZ(.2)=$G(^PS(55,DA(1),5,DA,.2))
+ S X(1)=$P(DIKZ(.2),U,8)
+ S DIKZ(0)=$G(^PS(55,DA(1),5,DA,0))
+ S X(2)=$P(DIKZ(0),U,21)
+ S X=$G(X(1))
+ I $G(X(1))]"",$G(X(2))]"" D
+ . K X1,X2 M X1=X,X2=X
+ . S:$D(DIKIL) (X2,X2(1),X2(2))=""
+ . N DIKXARR M DIKXARR=X S DIKCOND=1
+ . S X=1
+ . S DIKCOND=$G(X) K X M X=DIKXARR
+ . Q:'DIKCOND
+ . K ^PS(55,"ACX",$E(X(1),1,30),$E(X(2),1,30),DA_"U")
+CR3 S DIXR=495
  K X
  S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
@@ -71,5 +71,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . K ^PS(55,"AUDC",$E(X(1),1,20),$E(X(2),1,20),DA(1),DA)
-CR4 S DIXR=501
+CR4 S DIXR=497
  K X
  S DIKZ(2)=$G(^PS(55,DA(1),5,DA,2))
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR9.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR9.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSJXR9.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSJXR9 ; COMPILED XREF FOR FILE #55.02 ; 12/12/07
+PSSJXR9 ; COMPILED XREF FOR FILE #55.02 ; 01/17/08
  ; 
  S DA(2)=DA(1) S DA(1)=0 S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSMARK.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSMARK.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSMARK.m	(revision 636)
@@ -1,4 +1,4 @@
 PSSMARK ;BIR/WRT-Review single NDF matches for CMOP ; 10/27/98 13:44
- ;;1.0;PHARMACY DATA MANAGEMENT;**15,17,20,28,57,82,124**;9/30/97;Build 2
+ ;;1.0;PHARMACY DATA MANAGEMENT;**15,17,20,28,57,82**;9/30/97
  ;
  ;Reference to ^PS(59 supported by DBIA #1976
@@ -35,8 +35,5 @@
  Q
 BLD ;
- I $D(^PSDRUG(PSXUM,"I")) D  ;; <*124 RJS
- .N X,X1,X2
- .S X1=$G(^PSDRUG(PSXUM,"I")),X2=DT D ^%DTC
- .S:X<1 PSSEXP(1)="It has been inactivated."  ;; *124 RJS >
+ I $D(^PSDRUG(PSXUM,"I")) S PSSEXP(1)="It has been inactivated."
  I $D(^PSDRUG(PSXUM,2)),$P(^PSDRUG(PSXUM,2),"^",3)'["O" S PSSEXP(2)="It is not marked for outpatient pharmacy use."
 BLD5 I $P(^PSDRUG(PSXUM,0),"^",3)[1!($P(^(0),"^",3)[2) S PSSEXP(3)="It is a schedule I or schedule II controlled substance."
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX6.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX6.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX6.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX6 ; DRIVER FOR COMPILED XREFS FOR FILE #52.6 ; 03/08/06
+PSSVX6 ; DRIVER FOR COMPILED XREFS FOR FILE #52.6 ; 04/10/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX61.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX61.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX61.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX61 ; COMPILED XREF FOR FILE #52.6 ; 03/08/06
+PSSVX61 ; COMPILED XREF FOR FILE #52.6 ; 04/10/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX62.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX62.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX62.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX62 ; COMPILED XREF FOR FILE #52.61 ; 03/08/06
+PSSVX62 ; COMPILED XREF FOR FILE #52.61 ; 04/10/06
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX63.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX63.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX63.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX63 ; COMPILED XREF FOR FILE #52.63 ; 03/08/06
+PSSVX63 ; COMPILED XREF FOR FILE #52.63 ; 04/10/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX64.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX64.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX64.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX64 ; COMPILED XREF FOR FILE #52.6 ; 03/08/06
+PSSVX64 ; COMPILED XREF FOR FILE #52.6 ; 04/10/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX65.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX65.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX65.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX65 ; COMPILED XREF FOR FILE #52.61 ; 03/08/06
+PSSVX65 ; COMPILED XREF FOR FILE #52.61 ; 04/10/06
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX66.m
===================================================================
--- FOIAVistA/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX66.m	(revision 631)
+++ FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSVX66.m	(revision 636)
@@ -1,3 +1,3 @@
-PSSVX66 ; COMPILED XREF FOR FILE #52.63 ; 03/08/06
+PSSVX66 ; COMPILED XREF FOR FILE #52.63 ; 04/10/06
  ; 
  S DA=0
Index: FOIAVistA/tag/r/POLICE_AND_SECURITY-ES/ESPQNC.m
===================================================================
--- FOIAVistA/trunk/r/POLICE_AND_SECURITY-ES/ESPQNC.m	(revision 631)
+++ FOIAVistA/tag/r/POLICE_AND_SECURITY-ES/ESPQNC.m	(revision 636)
@@ -1,4 +1,4 @@
-ESPQNC ;Albany/VAD - QUICK NAME CHECK ; 11/27/07 2:15pm
- ;;1.0;POLICE & SECURITY;**2,18,21,29,45**;Mar 31, 1994;Build 1
+ESPQNC ;Albany/VAD - QUICK NAME CHECK ;Nov 3, 1999
+ ;;1.0;POLICE & SECURITY;**2,18,21,29**;Mar 31, 1994
 START W !! S DIC("A")="Select Name: ",DIC="^ESP(910,",DIC(0)="AEMQZ" D ^DIC I Y<0 G EXIT
  S ESPNAM=+Y W !?5,"SEX: ",$P(^ESP(910,ESPNAM,0),"^",8),?20,"RACE: ",$S($D(^DIC(10,+$P(^(0),"^",9),0)):$P(^DIC(10,+$P(^ESP(910,ESPNAM,0),"^",9),0),"^",1),1:""),!!
@@ -56,5 +56,5 @@
  D ^DIR S ESPX=X W !
  I $D(DTOUT) S ESPSTP=1 Q
- I X["^" S ESPSTP=1 Q
+ I X="^" S ESPSTP=1 Q
  I X=""&'ESPLAST S ESPSTP=0,ESPCNT=0 Q
  I X=""&ESPLAST S ESPSTP=1 Q
Index: FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLBLDC.m
===================================================================
--- FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLBLDC.m	(revision 631)
+++ FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLBLDC.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPLBLDC ; SLC/MKB -- Build Problem Selection Categories ;3/12/03 9:22
- ;;2.0;Problem List;**3,7,28**;Aug 25, 1994
+ ;;2.0;Problem List;**3,7,28**;Aug 25, 1994;Build 1
  ;
  ; This routine invokes IA #3991
Index: FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLENFM.m
===================================================================
--- FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLENFM.m	(revision 631)
+++ FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLENFM.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPLENFM ; SLC/MKB/KER -- Problem List Enc Form utilities ; 04/15/2002
- ;;2.0;Problem List;**3,4,7,26**;Aug 25, 1994
+ ;;2.0;Problem List;**3,4,7,26**;Aug 25, 1994;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLHIST.m
===================================================================
--- FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLHIST.m	(revision 631)
+++ FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLHIST.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPLHIST ; SLC/MKB/KER -- Problem List Historical data ; 04/15/2002
- ;;2.0;Problem List;**7,26,31**;Aug 25, 1994
+ ;;2.0;Problem List;**7,26,31**;Aug 25, 1994;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLUTL1.m
===================================================================
--- FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLUTL1.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPLUTL1 ; SLC/MKB/KER -- PL Utilities (cont)               ; 04/15/2002
- ;;2.0;Problem List;**3,8,7,9,26**;Aug 25, 1994
+ ;;2.0;Problem List;**3,8,7,9,26**;Aug 25, 1994;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLX.m
===================================================================
--- FOIAVistA/trunk/r/PROBLEM_LIST-GMPL/GMPLX.m	(revision 631)
+++ FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLX.m	(revision 636)
@@ -1,4 +1,4 @@
 GMPLX ; SLC/MKB/AJB -- Problem List Problem Utilities ; 02/27/2004
- ;;2.0;Problem List;**7,23,26,28,27**;Aug 25, 1994
+ ;;2.0;Problem List;**7,23,26,28,27**;Aug 25, 1994;Build 1
  ;
  ; External References
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOBIL5.m	(revision 636)
@@ -1,5 +1,4 @@
 RMPOBIL5 ;(NG)/DUG - HOME OXYGEN BILLING TRANSACTIONS ;7/24/98
- ;;3.0;PROSTHETICS;**29,99,137**;Feb 09, 1996;Build 5
- N RMPRMERG S RMPRMERG=0
+ ;;3.0;PROSTHETICS;**29,99**;Feb 09, 1996
  S (RC,RA,AN,ANS,RK,RZ)=0 D HDR
  F  S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA=""  D
@@ -7,13 +6,4 @@
  . F  S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN=""  D
  . . I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN
- ;Check for merged accounts
- I $D(^XDRM("B",RMPRDFN_";DPT(")) D
- . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""
- . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0  D
- .. S RA=0
- .. F  S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA=""  D
- ... S AN=""
- ... F  S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN=""  D
- .... I $D(^RMPO(665.72,"AC",AN))>0 S RC=RC+1,IT(RC)=AN
  G:'$D(IT) END
 DIS ;DISPLAY APPLIANCES OR REPAIRS
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPOPED.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPOPED ;EDS/MDB,DDW,RVD - HOME OXYGEN MISC FILE EDITS ;7/24/98
- ;;3.0;PROSTHETICS;**29,44,41,52,77,110,140**;Feb 09, 1996;Build 10
+ ;;3.0;PROSTHETICS;**29,44,41,52,77,110**;Feb 09, 1996;Build 10
  ;
  ; HNC - patch 52
@@ -11,5 +11,5 @@
 UNLOCK I $D(RMPODFN) L -^RMPR(665,RMPODFN)
  Q
-EXIT D KILL^XUSCLEAN
+EXIT K DIC,DIE,DIR,DIK,X,Y,Z,DR,DA,DD,DO,D0,DTOUT,DIROUT,DUOUT,DIRUT,QUIT,DFN,ITEM,ITEMS,IEN,IENS,ITMACT,ITM,C,S,W,PI,VDR,ZST
  D UNLOCK
  Q
@@ -171,10 +171,9 @@
 RX ;Edit the Rx Data
  ;
- N RXD,RXDI
  K DIC,DIE,DA,DR
  S DIC="^RMPR(665,"_RMPODFN_",""RMPOB"",",DIC(0)="AEQLZ"
  S DA(1)=RMPODFN,DIC("P")="665.193D"
- S RXD=$O(^RMPR(665,DA(1),"RMPOB","B",""),-1) D:RXD
- . S DIC("B")=$$FMTE^XLFDT(RXD)
+ I $D(^DISV(DUZ,DIC)) S Y=^(DIC) I $D(@(DIC_(+Y)_",0)")) D
+ . S DIC("B")=$P(^(0),U,1)
  D ^DIC Q:Y<0!$$QUIT
  S DIE=DIC,DA=+Y,DR=".01;2//^D EXPIRE^RMPOBIL4;3" D ^DIE Q:$$EQUIT
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR121B.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR121B ;PHX/HNC -POST GUI PURCHASE ORDER TRANSACTION ;3/1/2003
- ;;3.0;PROSTHETICS;**90,75,137**;FEB 09,1996;Build 5
+ ;;3.0;PROSTHETICS;**90,75**;FEB 09,1996;Build 25
  ;Per VHA Directive 10-93-142, this routine should not be modified.
 A1(SIG,RMPRA,RMPRSITE) S RMPRGUI=1 G A2
@@ -20,8 +20,7 @@
  S PRCRMPR=1,X=1,PRCRMPR=1
  D UP1^PRCH7PUC(.X,PRCA,PRCB,PRCC,PRCSITE,PRCVEN,PRCRMPR)
- I X="^" D C664 G QUIT
+ I X="^" G QUIT
  S PRC442=$P(^RMPR(664,RMPRA,4),U,6)
  I $P(^PRC(442,PRC442,7),U,1)'=6 G QUT
- S $P(^RMPR(664,RMPRA,0),U,5)="",$P(^RMPR(664,RMPRA,2),U)="",$P(^RMPR(664,RMPRA,2),U,2)=""
  I $D(RMPRPSC) S $P(^RMPR(664,RMPRA,2),U,5)=RMPRPSC
  S DA=RMPRA,DIK="^RMPR(664," D IX1^DIK
@@ -83,6 +82,2 @@
  D DELIV^RMPR121A
  Q
-C664 ;CANCEL 664 ENTRY WHEN IFCAP IS CANCELLED
- S $P(^RMPR(664,RMPRA,0),U,5)=$P(^RMPR(664,RMPRA,0),U),$P(^RMPR(664,RMPRA,2),U,2)=+DUZ
- S WDS="INSUFF FUNDS CANCEL",DA=RMPRA,DR="3.1////^S X=WDS",DIE="^RMPR(664," D ^DIE K WDS
- Q
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94  11:22 AM ]
- ;;3.0;PROSTHETICS;**12,13,28,41,142**;Feb 09, 1996;Build 2
+ ;;3.0;PROSTHETICS;**12,13,28,41**;Feb 09, 1996
 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660
  I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q
@@ -11,5 +11,4 @@
  F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0  I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12) D
  .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2)
- .I RDA,'$D(^RMPR(660,RDA,0)) S RDA=""
  .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=RMPRDT D FILE^DICN K DLAYGO Q:+Y'>0  S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=RMPRDT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPRDT
 DR .K DR S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT"
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29BG.m	(revision 636)
@@ -1,9 +1,9 @@
 RMPR29BG ;OI-HINES/SPS -OWL BASE HCPCS ENTER/EDIT/DELETE RPC;12/27/2004
- ;;3.0;PROSTHETICS;**75,142**;Feb 09, 1996;Build 2
+ ;;3.0;PROSTHETICS;**75**;Feb 09, 1996;Build 25
 A1(RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN) ;roll and scroll entry point
  G A2
 EN(RESULTS,RMAED,RMPRSITE,RMIE1,RMIE16,RMITM,RMQTY,RMUI,RMTT,RMPC,RMSN,RMHCPC,RMCPTM,RMVEN,RMBD,RMHTECH,RMPRTXT) ;RPC entry point
 A2 ;
- N J,L,RESULTS,RMIE16C,RMIE16F,R6641,RSITE
+ N J,L,RESULTS,RMIE16C,RMIE16F
  S RESULTS(0)=""
  K ^TMP($J)
@@ -16,7 +16,4 @@
  S ^TMP("SPS",0)=RMAED_U_RMPRSITE_U_RMIE1_U_RMIE16_U_RMITM_U_RMQTY_U_RMUI_U_RMTT_U_RMPC_U_RMSN_U_RMHCPC_U_RMCPTM_U_RMVEN
  S RMIE16F=$O(^RMPR(664.1,RMIE1,2,0))
- S R6641=$G(^RMPR(664.1,RMIE1,0))
- S RSITE=$P(R6641,U,15),RSITE=$O(^RMPR(669.9,"C",RSITE,0))
- I RSITE'=RMPRSITE S RMPRSITE=RSITE
  I RMIE16F>0 S:RMIE16'=RMIE16F RMTT=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7),RMPC=$P(^(0),U,8)
  I RMIE16=RMIE16F D:RMTT'=$P(^RMPR(664.1,RMIE1,2,RMIE16F,0),U,7)!(RMPC'=$P(^(0),U,8))
@@ -60,11 +57,9 @@
 DEL ;
  S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,5)
- I DA'="" D
- . S DIK="^RMPR(660," D ^DIK
- . K DA,DIK
+ S DIK="^RMPR(660," D ^DIK
+ K DA,DIK
  S DA=$P(^RMPR(664.1,RMIE1,2,RMIE16,0),U,6)
- I DA'="" D
- . S DIK="^RMPR(664.2," D ^DIK
- . K DA,DIK
+ S DIK="^RMPR(664.2," D ^DIK
+ K DA,DIK
  S DA(1)=RMIE1,DA=RMIE16,DIK="^RMPR(664.1,"_DA(1)_",2," D ^DIK
  K DA,DIK
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29CA.m	(revision 636)
@@ -1,9 +1,9 @@
 RMPR29CA ;OI-HINES/HNC,SPS -WORK ORDER SUSPENSE RPC;12/27/2004
- ;;3.0;PROSTHETICS;**75,122,142**;Feb 09, 1996;Build 2
+ ;;3.0;PROSTHETICS;**75,122**;Feb 09, 1996;Build 2
 A1(RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;roll and scroll entry point
  G A2
 EN(RESULTS,RMIE68,RMPRDUZ,RMSUSTAT,RMPR6641,RMPRTXT) ;RPC entry point
 A2 ;
- S RESULTS(0)="",STP=0
+ S RESULTS(0)=""
  K ^TMP($J)
  ;
@@ -11,11 +11,8 @@
  ;3=cancel or 4=cancel and clone 
  S RMIE=0
- F  S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0  D  Q:STP=1
- .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5) Q:'RMIE60
+ F  S RMIE=$O(^RMPR(664.1,RMPR6641,2,RMIE)) Q:RMIE'>0  D
+ .S RMIE60=$P(^RMPR(664.1,RMPR6641,2,RMIE,0),U,5)
  .S ^TMP($J,RMIE60)=""
- .D FD
- .I STP=1 Q
- .D UPD
- I STP=1 G EXIT
+ .D FD,UPD
  I RMSUSTAT=1 D CNOTE
  I RMSUSTAT=0 D INOTE,FD
@@ -24,5 +21,5 @@
  I RMSUSTAT=4 D CANOTE^RMPR29CB
  ;set status
- G EXIT
+ Q
 CNOTE ;(#12) COMPLETION NOTE
  ;set file 668
@@ -101,6 +98,9 @@
  D ^DIC
  I Y=-1 S RESULTS(0)="1^Error Modifying Record!" Q
+ ;S DIE=DIC K DIC
  S (DA,RMPRDA2)=+Y
+ ;S DR="1" D ^DIE
  K DIE,DR,Y
+ ;S ^RMPR(668,RMIE68,1,0)="^668.011DA^1^1"
  N RMPRC
  S L="",LN=0
@@ -167,5 +167,5 @@
  S:RMSUSTAT="" RMSUSTAT=0
  L +^RMPR(660,RMIE60):2
- I $T=0 S RESULTS(0)="1^Someone else is Editing this entry! If this problem persists contact your IRM to clear the Lock Table",STP=1 Q
+ I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" G EXIT
  S RM680=$G(^RMPR(668,RMIE68,0))
  S RM688=$G(^RMPR(668,RMIE68,8))
@@ -202,19 +202,18 @@
  D FILE^DIE("","RMDAT","RMERROR")
  L -^RMPR(660,RMIE60)
- I $D(RMERROR) S RMERR=1,STP=1 G ERR
+ I $D(RMERROR) S RMERR=1 D ERR
  ;
  Q
 UPD ;update file 668 with 2319 records
- K DD,DO
+ K DD,D0
  S DA(1)=RMIE68
  S DIC="^RMPR(668,"_DA(1)_","_"10,"
  S DIC(0)="L",DLAYGO=668,X=RMIE60
  D FILE^DICN
- K X,DD,DO
  S DA(1)=RMIE68
  S DIC="^RMPR(668,"_DA(1)_","_"11,"
  S X=RMAMIS
  D FILE^DICN
- K DIC,X,DLAYGO,DO
+ K DIC,X,DLAYGO,D0
  Q
 A3 G A4
@@ -226,7 +225,6 @@
  Q
 ERR ;exit on error
- S RESULTS(0)="1^ERROR WAS "_RMERROR("DIERR",1,"TEXT",1)
 EXIT ;
- K %,BDC,RM688,RMAA,RMAMIS,RMCODT,RMDAT,RMDWRT,RMICD9,RMIE,RMIE60,RMINDT
- K RMPRCO,RMPRDI,RMSERV,RMSTAT,RMTRES,RMTYRE,STP
- Q
+ K RMTYRE,RMTRES,RMSUSTAT,RMSTAT,RMSERV,RMEQU,RMPRTST,RMPRDUZ,RMPRDI,RMPRCO,RMPR6641,RMIE68
+ K RMIE60,RMIE,RMICD9,RMDWRT,RMDAT,RMCODT,RMAMIS,RMAA,RM688,RMPRTXT
+ K BDC,BAD,%,RMINDT,RMPREQU
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR29GA ;PHX/JLT,RVD,SPS-RMPR29 CONTINUED [ 09/29/94  11:22 AM ]
- ;;3.0;PROSTHETICS;**75,60,142**;Feb 09, 1996;Build 2
+ ;;3.0;PROSTHETICS;**75,60**;Feb 09, 1996;Build 18
  ; Developed form RMPR29A for the GUI application
 POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660
@@ -14,5 +14,4 @@
  .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2),RMHTECH=$P($G(^(2)),U,3)
  .;Changed .01 and 1 fields to create date DT below 5/25/06 for 75 SPS
- .I RDA,'$D(^RMPR(660,RDA,0)) S RDA=""
  .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=DT D FILE^DICN K DLAYGO Q:+Y'>0  S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=DT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=DT
 DR .K DR
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4C21.m	(revision 636)
@@ -1,5 +1,5 @@
 RMPR4C21 ;PHX/HNB-CANCEL A PURCHASE CARD TRANSACTION;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,62,140**;Feb 09, 1996;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+ ;;3.0;PROSTHETICS;**3,20,62**;Feb 09, 1996
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;RVD patch #62 - pce interface
  ;
@@ -25,5 +25,4 @@
  S RMPR442=$P($G(^RMPR(664,RMPRA,4)),U,6)
  I RMPR442="" G BYPASS
- I $P($G(^PRC(442,RMPR442,7)),U)=45 W !!,"Purchase Card CANCELLED in IFCAP, will cancel open Pros PC order, hit return" R X:10 G BYPASS
  D CAN^PRCH7B(.X,RMPRA,RMPR442,0)
  I X="^" W !!,"NOT CANCELED You must say YES to 'Approve and print Amendment number'" G EXIT
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4E21.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR4E21 ;PHX/HNC - CLOSE OUT PURCHASE CARD TRANSACTION ;3/1/1996
- ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133,137**;Feb 09, 1996;Build 5
+ ;;3.0;PROSTHETICS;**3,12,26,28,30,34,41,45,62,111,78,114,118,133**;Feb 09, 1996;Build 2
  ;TH  Patch #78 - 08/04/03 - Add shipment date. Call routine ^RMPR4E23
  ;RVD patch #62 - PCE processing and link to suspense
@@ -25,5 +25,4 @@
  S RM(RMPRA,0)=$G(^RMPR(664,RMPRA,0)),RM(RMPRA,2)=$G(^(2)),RM(RMPRA,4)=$G(^(4))
  S RMPER=$P(RM(RMPRA,2),U,6),RMBAN=$P(RM(RMPRA,4),U,2),RMSHI=$P(RM(RMPRA,0),U,11),RMSHIEN=$P(RM(RMPRA,0),U,12)
- S:RMSHI=""!(RMSHI+0=0) RMSHI=0
  ;added by #62
  ;collect all items and previous linkage to suspense.
@@ -78,8 +77,8 @@
  I $P(^RMPR(664,RMPRA,0),U,11)="",$P(^(0),U,10) S $P(^(0),U,11)=$P(RM(RMPRA,0),U,10)
  S DA=RMPRA,DIE="^RMPR(664,",DR="12;17;26" D ^DIE
- S:+$P(^RMPR(664,RMPRA,0),U,11)=0 $P(^(0),U,11)=0
  I RMPER'=$P(^RMPR(664,RMPRA,2),U,6) S RMPERF=1
  I RMBAN'=$P(^RMPR(664,RMPRA,4),U,2) S RMBANF=1
- I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11)!($P(^(0),U,11)=0&$P(^(0),U,12)) S RMSHIF=1
+ I RMSHI'=$P(^RMPR(664,RMPRA,0),U,11) S RMSHIF=1
+ S:$P(^RMPR(664,RMPRA,0),U,11)="" $P(^(0),U,11)=0
 CHK1 ;delete imcomplete items
  S DIK="^RMPR(664,"_RMPRA_",1,",DA(1)=RMPRA F I=0:0 S I=$O(^RMPR(664,RMPRA,1,I)) Q:I'>0  S RMPRI=$G(^(I,0)) I $P(RMPRI,U,3)=""!($P(RMPRI,U,4)="")!($P(RMPRI,U,5)="") S DA=I D ^DIK
@@ -140,7 +139,4 @@
  .I DA'="" S SKPSHDT=1 D ^RMPR4E23 K SKPSHDT
 EX1 ;
- I $D(RM60LINK) D
- . F I=0:0 S I=$O(RM60LINK(I)) Q:I'>0  D
- .. I '$D(^RMPR(660,I,0)) K RM60LINK(I)
  ;added by #62
  D:$D(RM68FG)=1 AUTO^RMPRPCEL D:$D(RM68FG)>1 MAN^RMPRPCEL
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4LOP.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR4LOP ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10
+ ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996
  ;sort by originator, assistance from Long Beach PVB
  W !,"This report lists Open Purchase Card Transactions created in the"
@@ -23,5 +23,5 @@
 EXIT I $E(IOST)["C"&($Y<20) F  W ! Q:$Y>20
  I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR
-EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J),PRCIEN D ^%ZISC
+EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J) D ^%ZISC
  K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS,INIC,INIB
  Q
@@ -41,7 +41,7 @@
  I DUZ=$P(^RMPR(664,RP,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W $$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP)
  E  W "encrypted"
- S RD=$P(^RMPR(664,RP,0),U,1),PRCIEN=$P(^RMPR(664,RP,4),U,6)
+ S RD=$P(^RMPR(664,RP,0),U,1)
   S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7)
- W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#"
+ W ?36,RD
  W ?43,$P(^RMPR(664,RP,4),U,5)
  W ?50
@@ -69,3 +69,3 @@
 HDR I PAGE'=1!($E(IOST)["C") W @IOF
  I $E(IOST)["C" W @IOF G EXIT:X="^"
- W !,RMPRX_"-",RMPRY," Open 2421PC Transactions     "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",! S PAGE=PAGE+1 Q
+ W !,RMPRX_"-",RMPRY," Open 2421PC Transactions     "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4OPN.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR4OPN ;PHX/HNB - LIST OPEN PURCHASE CARD TRANSACTIONS ;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,140**;Feb 09, 1996;Build 10
+ ;;3.0;PROSTHETICS;**3,20**;Feb 09, 1996
  W !,"This report lists Open Purchase Card Transactions created in the"
  W !,"Prosthetics Package."
@@ -18,5 +18,5 @@
 EXIT I $E(IOST)["C"&($Y<20) F  W ! Q:$Y>20
  I $D(RMPREDT),'$D(DTOUT),'$D(DUOUT),$E(IOST)["C",'$D(RMPRFLL),RMPREND'=1 S DIR(0)="E" D ^DIR
-EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J),PRCIEN D ^%ZISC
+EX K RMPREND,RMPROBL,RMPRFLL,RMPRFLG,DUOUT,DIR,RO,RP,RMPRY,RMPRCOUN,RMPRX,RMPRBDT,RMPREDT,RMPRCK,%DT,X,Y,PAGE,IT,ZTSK,^TMP($J) D ^%ZISC
  K CNT,DTOUT,ROBL,X1,X2,RMPR,%ZIS
  Q
@@ -36,7 +36,7 @@
  I DUZ=$P(^RMPR(664,RP,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) W $$DEC^RMPR4LI($P(^RMPR(664,RP,4),U,1),$P(^RMPR(664,RP,0),U,9),RP)
  E  W "encrypted"
- S RD=$P(^RMPR(664,RP,0),U,1),PRCIEN=$P(^RMPR(664,RP,4),U,6)
+ S RD=$P(^RMPR(664,RP,0),U,1)
  S RD=$P(RD,"."),RD=$E(RD,4,5)_"/"_$E(RD,6,7)
- W ?36,RD I PRCIEN,($P($G(^PRC(442,PRCIEN,7)),U)=45) W "#"
+ W ?36,RD
  W ?43,$P(^RMPR(664,RP,4),U,5)
  W ?50
@@ -59,3 +59,3 @@
  Q
 HDR I PAGE'=1!($E(IOST)["C") W @IOF
- W !,RMPRX_"-",RMPRY," Open 2421PC Transactions     "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,!,"# = PURCHASE CARD Order CANCELLED on IFCAP SYSTEM",! S PAGE=PAGE+1 Q
+ W !,RMPRX_"-",RMPRY," Open 2421PC Transactions     "_"STA "_$$STA^RMPRUTIL,?72,"PAGE ",PAGE,! S PAGE=PAGE+1 Q
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR4P21.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR4P21 ;PHX/HNC,RVD -PRINT PURCHASE CARD ORDER ;3/1/1996
- ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133,139**;Feb 09, 1996;Build 4
+ ;;3.0;PROSTHETICS;**3,15,19,26,55,90,132,133**;Feb 09, 1996;Build 2
  ;
  ; ODJ - patch 55 - 1/29/01 - replace hard code mail route symbol 121
@@ -63,6 +63,5 @@
  I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance  CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION"
  W !,RMPRB
- ;Remove claim number print in *139 since it held SSN at times
- W !,"7. Claim Number",?40,"8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time"
+ W !,"7. Claim Number"_" "_VAEL(7),?40,"8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time"
  S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10)
  S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"")
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR8PG.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR8PG ;PHX,HOIFO/JLT,SPS-PURGE 668 SUSPENSE FILE ;8/29/1994
- ;;3.0;PROSTHETICS;**5,75,140**;Feb 09, 1996;Build 10
+ ;;3.0;PROSTHETICS;**5,75**;Feb 09, 1996;Build 25
  ;
  ;02/03/06 Added code to delete the pointer in 664.1 field .05 when a 
@@ -14,7 +14,6 @@
  S DIS(0)="I $P(^RMPR(668,D0,0),U,7)=RMPR(""STA"")",IOP=ION,DIC="^RMPR(668,",FLDS=".01;C1,1;C20;L17,2,3,6;C45;L15,5;C65,4;C1,7;C1",BY="5",FR=$S($D(^RMPR(668,"B")):$O(^RMPR(668,"B","")),1:2890101)
  S TO=RMPRDT,DHD="Purge Suspense File Entries from Station/Division "_RMPR("STA") D EN1^DIP
- N RMPR6641
  F  S RMPRIEN=$O(^RMPR(668,RMPRIEN)) Q:RMPRIEN'>0  I $P($G(^RMPR(668,RMPRIEN,0)),U,7)=RMPR("STA") I ($P(^RMPR(668,RMPRIEN,0),U,5))&($P(^(0),U,5)<RMPRDT) S DA=RMPRIEN,DIC="^RMPR(668," S DA=RMPRIEN,DIK=DIC D ^DIK D  S RDEL=RDEL+1
- . S RMPR6641=0 F  S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0  D
+ . F  S RMPR6641=$O(^RMPR(664.1,"SUS",DA,RMPR6641)) Q:RMPR6641'>0  D
  .. I $D(^RMPR(664.1,RMPR6641,0)) S $P(^(0),U,8)=""
 END I $G(RDEL)<1 W !!,"No Suspense entries purged."
@@ -22,3 +21,3 @@
  I $G(RDEL)=1 W !!,RDEL,"Suspense entry purged. "
 EXIT ;common exit point
- K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RMPR6641,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC Q
+ K I,RD,X,DIS,%ZIS,X1,X2,RMPRIEN,RMPRDT,RDEL,DIC,DIK,DA,RL,BY,DHD,DHIT,FLDS,FR,TO D ^%ZISC Q
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9CA.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR9CA ;OI-HINES/HNC -SUSPENSE RPC;12/27/2004
- ;;3.0;PROSTHETICS;**90,135,141**;Feb 09, 1996;Build 5
+ ;;3.0;PROSTHETICS;**90**;Feb 09, 1996
 A1 ;roll and scroll entry point
  G A2
@@ -137,5 +137,5 @@
  F  S RMPRCMT=$O(^RMPR(668,RMIE68,3,RMPRCMT)) Q:RMPRCMT=""  D
  .S GMRCMT(RMPRCMT)=^RMPR(668,RMIE68,3,RMPRCMT,0)
- D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)
+ S RMGMRCO=$$RC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCMT,DUZ)
  K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT
  S RESULTS(0)="0^Completed Suspense Action, and Posted note to CPRS Consult.  Suspense status has changed to PENDING."
@@ -190,14 +190,13 @@
  Q
 UPD ;update file 668 with 2319 records
- S DA(1)=RMIE68 K DD,DO,DIC
+ S DA(1)=RMIE68
  S DIC="^RMPR(668,"_DA(1)_","_"10,"
  S DIC(0)="L",DLAYGO=668,X=RMIE60
  D FILE^DICN
- K X,DD,DO,DIC
- S DA(1)=RMIE68,DIC(0)="L",DLAYGO=668
+ S DA(1)=RMIE68
  S DIC="^RMPR(668,"_DA(1)_","_"11,"
  S X=RMAMIS
  D FILE^DICN
- K DIC,X,DLAYGO,DD,DO
+ K DIC,X,DLAYGO
  Q
 A3 G A4
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9DO.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR9DO ;HOIFO/HNC -  ORDER CONROL PROCESSING-REMOTE PROCEDURE ;9/8/03  07:12
- ;;3.0;PROSTHETICS;**59,77,90,60,135**;Feb 09, 1996;Build 12
+ ;;3.0;PROSTHETICS;**59,77,90,60**;Feb 09, 1996;Build 18
  ;
  ;8/5/03 Make sure no dups, HNC patch 77
@@ -175,7 +175,6 @@
  ;PPD=1 for previous pending
  I ADATE'="" S (PDAY,WRKDAY)=$$WRKDAY^RMPREOU(RMPRA)
- I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA) I $P(^RMPR(668,RMPRA,0),U,10)="X" S (PDAY,WRKDAY)=$$CANWKDY^RMPREOU(RMPRA)
+ I ADATE="" S (PDAY,WRKDAY)=$$CWRKDAY^RMPREOU(RMPRA)
  I ADATE'="" S CDAY=$$PDAY^RMPREOU(RMPRA)
- ;
  S STATUS=$$STATUS^RMPREOU(RMPRA)
  I STATUS["PENDING" D
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR9P21.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPR9P21 ;PHX/SPS,HNC,RVD -SEND DATA TO PC TO PRINT PURCHASE CARD ORDER ;4/27/05
- ;;3.0;PROSTHETICS;**90,116,119,133,139**;Feb 09, 1996;Build 4
+ ;;3.0;PROSTHETICS;**90,116,119,133**;Feb 09, 1996;Build 2
  ;
 EN(RMPRA,RMPRSITE,RMPRPTR) ;ENTRY POINT FOR VISTA ROLL AND SCROLL
@@ -67,5 +67,5 @@
  I VAPA(2)'="" S ^TMP($J,"RMPRPRT",CNT+10)="    "_VAPA(8)_SPACE_"CHARGE MEDICAL APPROPRIATION"
  S ^TMP($J,"RMPRPRT",CNT+11)=RMPRB
- S ^TMP($J,"RMPRPRT",CNT+12)="7. Claim Number                        8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3)
+ S ^TMP($J,"RMPRPRT",CNT+12)="7. Claim Number   "_VAEL(7)_"             8. ID #:"_" "_$P($P(VADM(2),U,2),"-",3)
  S ^TMP($J,"RMPRPRT",CNT+13)=RMPRB
  S ^TMP($J,"RMPRPRT",CNT+14)="10. Statistical Data         11. FOB Point    12. Discount    13. Delivery Time"
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRD1.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRD1 ;PHX/HNB-DISPLAY LOOKUP ;10/19/1993 [ 06/28/94  3:17 PM ]<<= NOT VERIFIED >
- ;;3.0;PROSTHETICS;**38,141**;Feb 09, 1996;Build 5
+ ;;3.0;PROSTHETICS;**38**;Feb 09, 1996
 EN ;DISPLAY DATE,PATIENT,ITEM,COST FROM 660
  S Z=^RMPR(660,+Y,0)
@@ -22,6 +22,6 @@
  .F  S RMPRI=$O(^RMPR(664,+Y,1,RMPRI)) Q:$G(RMPRI)'>0  D
  ..S RMPRI1=$P(^RMPR(664,+Y,1,RMPRI,0),U,1) Q:$G(RMPRI1)'>0
- ..S RMPRIT=$P($G(^RMPR(661,RMPRI1,0)),U,1)
- ..S:RMPRIT RMPRN=$P(^PRC(441,RMPRIT,0),U,2) S:RMPRIT="" RMPRN="*MASTER ITEM DELETED*"
+ ..S RMPRIT=$P(^RMPR(661,RMPRI1,0),U,1)
+ ..S RMPRN=$P(^PRC(441,RMPRIT,0),U,2)
  ..W ?64,$E(RMPRN,1,15)
  ..I $O(^RMPR(664,+Y,1,RMPRI)) W !
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRDDC.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRDDC ;VACO/HNC - SERVER ROUTINE FOR DALC RECORD IN 660 ; 11/01/2006
- ;;3.0;PROSTHETICS;**60,141**;Feb 09, 1996;Build 5
+ ;;3.0;PROSTHETICS;**60**;Feb 09, 1996;Build 18
  ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
@@ -9,5 +9,4 @@
  ;loop msg
  K RMPRMSG
- N ERR
  S RMPRCNT=0
  S RMPRMSGC=0
@@ -51,7 +50,4 @@
  .; RMPRDAT,U,21 IS RESERVED FOR A RETURN NUMBER TBD SKIPPED
  .S RMPROS=$P($G(RMPRDATA),U,22)   ;ordering station
- .S RMPRSTA=$$FIND1^DIC(4,"","X",RMPROS,"D","","ERR")
- .I $D(ERR)!(RMPRSTA'>0) D
- .. S RMPR6699=$O(^RMPR(669.9,0)),RMPRSTA=$P(^RMPR(669.9,RMPR6699,0),U,2)
  .S X=$P($G(RMPRDATA),U,20)  ;return date
  .S X=$E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,3,4) D ^%DT S RMPRRT=Y
@@ -114,5 +110,5 @@
  K RMPRITM,RMPRHCPE,RMPRHCP,RMPRSTN,RMPRCMT,RMPRCOST,RMPRQTY,RMPRREF
  K RMPRSRL,RMPRVND,RMPRDUN,RMPRTAX,RMPRRT,DFN,RMPR(660),RMPRCNT,RMPRDATA
- K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN,RMPRSTA,RMPR6699
+ K RMPRFLG,RMPROUT,RMPRNAM,RMPRWHN,RMPRMSGC,RMPRPNAM,RMPRNPMN
  ;purge server message
  S XMSER="S."_XQSOP,XMZ=XQMSG D REMSBMSG^XMA1C
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOS.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPREOS ;HINES-CIOFO/HNC -Suspense Processing ; 2/25/04 10:26am
- ;;3.0;PROSTHETICS;**45,50,52,55,57,62,80,85,97,135**;Feb 09, 1996;Build 12
+ ;;3.0;PROSTHETICS;**45,50,52,55,57,62,80,85,97**;Feb 09, 1996
  ;
  ;  HNC - patch 52 - 9/22/00 Modify EN2 not to check for RMPRFLAG
@@ -72,10 +72,10 @@
  S GMRCO=$P(^RMPR(668,DA,0),U,15) Q:GMRCO=""
  ;note in array
- S RMPRCMT=0,GMRCMT=1
+ S RMPRCMT=0
  F  S RMPRCMT=$O(^RMPR(668,DA,3,RMPRCMT)) Q:RMPRCMT=""  D
  .S GMRCMT(RMPRCMT)=^RMPR(668,DA,3,RMPRCMT,0)
- I $G(GMRCMT(1))="" S GMRCMT(1)="nothing noted"
+ I $G(GMRCMT)="" S GMRCMT="nothing noted"
  ;call api
- D CMT^GMRCGUIB(GMRCO,.GMRCMT,DUZ,RMPREODT,DUZ)
+ S RMGMRCO=$$RC^GMRCGUIA(.GMRCO,DUZ,RMPREODT,.GMRCMT,DUZ)
  K RMPREODT,GMRCO,RMGMRCO,GMRCMT,RMPRCMT
  Q
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPREOU.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPREOU ;HINES/HNC -Suspense Processing Utility  ;2-2-2000
- ;;3.0;PROSTHETICS;**45,55,59,135**;Feb 09, 1996;Build 12
+ ;;3.0;PROSTHETICS;**45,55,59**;Feb 09, 1996
  ; Add new function for working days M-F.
  Q
@@ -104,14 +104,4 @@
  D WDAY
  Q RMTO
-CANWKDY(DA) ;*135 working days between create and cancel date for cancel w/o initial action records.
- ;holidays are counted as working days
- ;parm 1=ien 668, DA
- N RMTO,RB,RE
- S RB=$P($G(^RMPR(668,DA,0)),U)
- Q:RB="" 0
- S RE=$P(^RMPR(668,DA,5),U)
- Q:RE="" 0
- D WDAY
- Q RMTO
 WDAY ;       RB - begining date
  ;       RE - ending date
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRP21.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRP21 ;PHX/RFM-PRINT 10-2421 ;8/29/1994
- ;;3.0;PROSTHETICS;**3,19,55,90,129,133,139**;Feb 09, 1996;Build 4
+ ;;3.0;PROSTHETICS;**3,19,55,90,129,133**;Feb 09, 1996;Build 2
  ;
  ; ODJ - patch 55 - 1/29/01 - extrinsic to get mail routing code
@@ -6,5 +6,5 @@
  ;                            nois AUG-1097-32118
  ;
- I '$D(RMPR)!'$D(RMPRSITE) D DIV4^RMPRSIT Q:$D(X)
+ I '$D(RMPR) D DIV4^RMPRSIT Q:$D(X)
  I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1) S %ZIS="MQ" D ^%ZIS G:POP EX S ZTIO=ION G PT
  I $D(RMPRA)&('$P(^RMPR(669.9,RMPRSITE,0),U,5)) G ZIS
@@ -15,5 +15,5 @@
  S DIC("W")="D EN2^RMPRD1" D ^DIC G:Y<0 EX S RMPRA=+Y I $P(^RMPR(664,+Y,0),U,5) D M2^RMPRM
  D PR^RMPR21A I %'>0 G EX
- I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT
+ ;I +$P(^RMPR(669.9,RMPRSITE,0),U,5) I $D(RMPRA)&($D(^%ZIS(1,$P(^RMPR(669.9,RMPRSITE,0),U,5),0))) S IOP="Q;"_$P(^(0),U,1),%ZIS="Q" D ^%ZIS G:POP EX S ZTIO=ION G PT
 ZIS S %ZIS="QM" D ^%ZIS G:POP EX
  I '$D(IO("Q")) U IO G PRT
@@ -23,5 +23,5 @@
 PRT ;ENTRY POINT TO PRINT 2421S
  S %X="^RMPR(664,RMPRA,",%Y="R664(" D %XY^%RCR K %X,%Y
- S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),CP=$P($G(^PRCS(410,CP,0)),U,1),RMPRPAGE=2
+ S RDUZ=$P(R664(0),U,9),RDUZ=$P(^VA(200,RDUZ,0),U,1),DFN=$P(R664(0),U,2),RTN=$P(R664(0),U,7),CP=$P(R664(0),U,6),CP=$P(^PRCS(410,CP,0),U,1),RMPRPAGE=2
  D ADD^VADPT,DEM^VADPT,ELIG^VADPT
  W:$Y>0 @IOF W ?20,"OMB Number 2900-0188",?50,"PO#: "
@@ -59,6 +59,5 @@
  I VAPA(2)'="" W ?5,VAPA(2),?40,$E(RMPRB,1,40),!,?5,VAPA(4)_","_$P(VAPA(5),U,2)_" "_VAPA(6),?40,"9. Authority For Issuance  CFR 17.115",!,?5,VAPA(8),?43,"CHARGE MEDICAL APPROPRIATION"
  W !,RMPRB
- ;Remove claim number print in *139 since it held SSN at times
- W !,"7. Claim Number",?40,"8. SSN"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time"
+ W !,"7. Claim Number"_" "_VAEL(7),?40,"8. SSN"_" "_$P($P(VADM(2),U,2),"-",3),!,RMPRB,!,"10. Statistical Data",?30,"11. FOB Point",?46,"12. Discount",?61,"13. Delivery Time"
  S R664("E")=$O(R664(1,0)),CAT=$P(R664(1,R664("E"),0),U,10)
  S RMPRCAT=$S(CAT=1:"SC/OP",CAT=2:"SC/IP",CAT=3:"NSC/IP",CAT=4:"NSC/OP",1:"") S SPE=$P(R664(1,R664("E"),0),U,11)
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPAT2.m	(revision 636)
@@ -1,12 +1,7 @@
 RMPRPAT2 ;PHX/RFM/JLT/HNC-DISPLAY PATIENT ITEM ACTIVITY ;10/19/1993
- ;;3.0;PROSTHETICS;**32,34,29,44,99,75,137**;Feb 09, 1996;Build 5
- D HDR N RMPRMERG S RMPRMERG=0
+ ;;3.0;PROSTHETICS;**32,34,29,44,99,75**;Feb 09, 1996;Build 25
+ D HDR
  S (RA,AN,ANS,RK,RZ)=0 K ^TMP($J,"TT"),^TMP($J,"AG"),IT
  MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRDFN)
- ;Check for merged accounts
- I $D(^XDRM("B",RMPRDFN_";DPT(")) D
- . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""
- . S RMPRMERG=+^XDRM(RMPRMERG,0) Q:RMPRMERG=0
- . MERGE ^TMP($J,"TT")=^RMPR(660,"AC",RMPRMERG)
  S B=0
  F  S B=$O(^TMP($J,"TT",B)) Q:B'>0  D
@@ -21,5 +16,5 @@
  . .S ^TMP($J,"AG",GN,ND,BC)=B
  S B=""
- F  S B=$O(^TMP($J,"AG",B)) Q:+B=0  D
+ F  S B=$O(^TMP($J,"AG",B)) Q:B'>0  D
  .S BC=""
  .F  S BC=$O(^TMP($J,"AG",B,BC)) Q:BC'>0  D
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCEB.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRPCEB ;HIN/RVD-PROS PCE BACKGROUND UTILITY ; 1/23/04 8:09am
- ;;3.0;PROSTHETICS;**62,69,77,82,78,114,120,133,142**;Feb 09, 1996;Build 2
+ ;;3.0;PROSTHETICS;**62,69,77,82,78,114,120,133**;Feb 09, 1996;Build 2
  ;
  ;RVD patch #69 - add STATION in the error message.
@@ -27,5 +27,4 @@
  F  S RI=$O(^RMPR(660,RI)) Q:RI'>0  D
  .S RM600=$G(^RMPR(660,RI,0))
- .I $P(RM600,U,2)="" Q
  .S RM611=$G(^RMPR(660,RI,1))
  .S RM610=$G(^RMPR(660,RI,10))
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPCED.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRPCED ;Hines OIFO/RVD - Prosthetics/660/668/PCE DELETE ;7/30/02  09:39
- ;;3.0;PROSTHETICS;**62,70,121,131,141**;Feb 09, 1996;Build 5
+ ;;3.0;PROSTHETICS;**62,70,121,131**;Feb 09, 1996;Build 3
  ;RVD 7/1/02 - patch #70 - new RMPR variables before calling PCE.
  ;
@@ -52,5 +52,5 @@
  .S RMAMIS68=$G(^RMPR(660,I,"AMS")) S:RMAMIS68=RMAMIS RMCNT=RMCNT+1
  ;if no other line item of the same GROUPER #, then delete.
- I RMCNT=1,RMAMIEN D
+ I RMCNT=1 D
  .S DA=RMAMIEN
  .S DA(1)=RMIE68,DIK="^RMPR(668,"_DA(1)_",11,"
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIY7.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRPIY7 ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/18/02  15:17
- ;;3.0;PROSTHETICS;**61,118,139**;Feb 09, 1996;Build 4
+ ;;3.0;PROSTHETICS;**61,118**;Feb 09, 1996
  ;
  ;DBIA # 800 - FILEMAN read of file #440.
@@ -21,7 +21,5 @@
  S RMPR5("IEN")=""
 LOCNM1 D ^DIR
- ;Patch *139 removes upper case translation to allow access to lower
- ;case entries used in location creation option
- ;S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+ S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  I $G(RMPR5("IEN"))'="" S RMPREXC="" G LOCNMX
  I $D(DTOUT) S RMPREXC="T" G LOCNMX
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPIYF.m	(revision 636)
@@ -1,4 +1,4 @@
 RMPRPIYF ;PHX/RFM,RVD-EDIT ISSUE FROM STOCK ;8/2/02  07:27
- ;;3.0;PROSTHETICS;**61,117,139**;Feb 09, 1996;Build 4
+ ;;3.0;PROSTHETICS;**61,117**;Feb 09, 1996
  ; RVD #61 - phase III of PIP enhancement.
  ;
@@ -75,6 +75,19 @@
  ;
 DEL1 ;ENTRY POINT TO DELETE AN ISSUE FROM STOCK
- ;** MOVED TO RMPRPIFD DUE TO SIZE CONSTRAINTS
- G DEL1^RMPRPIFD
+ K DIR
+ S DIR("A")="Are you sure you want to DELETE this entry",DIR("B")="N",DIR(0)="Y"
+ D ^DIR I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) G EXIT
+ I Y'=1 G CO^RMPRPIYE
+ ;
+DEL2 ;call API for returning item to PIP
+ S (RMCHK,RMERPCE)=0
+ S RMI68=$P($G(^RMPR(660,RMPRIEN,10)),U,1) I RMI68>0 D  I RMERPCE W !!,"** STOCK ISSUE DELETE ABORTED",!! G EXIT
+ .S RMCHK=$$DEL^RMPRPCED(RMPRIEN)
+ .I RMCHK'=0 W !!,"*** ERROR in PCE DELETE, Please notify your IRM..660 IEN = ",RMPRIEN,!! S RMERPCE=1 H 3
+ S RMPR60("IEN")=RMPRIEN
+ S RMCHK=$$DEL^RMPRPIU3(.RMPR60)
+ I $G(RMCHK) W !,"*** Error in API RMPRPIU3, ERROR = ",RMCHK,!,"*** Please inform your IRM !!",! G EXIT
+ ;
+ W $C(7),!?10,"Deleted..." H 1
 EXIT ;KILL VARIABLES AND EXIT ROUTINE
  I $G(RMPRIEN),$D(^RMPR(660,RMPRIEN)) L -^RMPR(660,RMPRIEN)
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRPRT1.m	(revision 636)
@@ -1,11 +1,7 @@
 RMPRPRT1 ;PHX/HNB-CONTINUATION OF PRINT 2319 ;10/19/1993
- ;;3.0;PROSTHETICS;**10,99,137,141**;Feb 09, 1996;Build 5
+ ;;3.0;PROSTHETICS;**10,99**;Feb 09, 1996
  ;CALLED BY END^RMPRPRT
  ;VARIABLES REQUIRED: R5 - A STRING ARRAY HOLDING PATIENT'S PROSTHETIC
  ;                         DISABILITY CODE INFORMATION
- N RMPRMERG S RMPRMERG=0
- I $D(^XDRM("B",RMPRDFN_";DPT(")) D
- . S RMPRMERG=$O(^XDRM("B",RMPRDFN_";DPT(",RMPRMERG)) Q:RMPRMERG=""
- . S RMPRMERG=+^XDRM(RMPRMERG,0)
  I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
  W !!,"PSC Issue Card: " S J=0 W !
@@ -47,7 +43,4 @@
  S RA=""
  F  S RA=$O(^RMPR(660,"AC",RMPRDFN,RA)) Q:RA'>0  S AN="" F  S AN=$O(^RMPR(660,"AC",RMPRDFN,RA,AN)) Q:AN'>0  S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
- S RA=""
- I RMPRMERG D
- . F  S RA=$O(^RMPR(660,"AC",RMPRMERG,RA)) Q:RA'>0  S AN="" F  S AN=$O(^RMPR(660,"AC",RMPRMERG,RA,AN)) Q:AN'>0  S RC=RC+1,Y=^RMPR(660,AN,0) D PRT I $Y>(IOSL-6) W @IOF D HDR^RMPRPRT
  I RC=0 W !,"No Appliances or Repairs exist for this veteran!",!!
  E  W !!,"End of Appliance/Repair records for this veteran!",!!," *Historical Item"
@@ -82,5 +75,5 @@
  K RMPRLPRO
  I VEN'="" W ?33,$E(VEN,1,10)
- W:$G(STA)'="" ?45,$P($G(^DIC(4,STA,99)),U,1) W ?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2)
+ W ?45,$P(^DIC(4,STA,99),U,1),?50,$E(SN,1,10),?62,DEL,?72,$J($S(CST'="":CST,$P(Y,U,17):$P(Y,U,17),1:""),0,2)
  W:REM]"" !,?5,"REMARKS: ",REM I $Y+6>IOSL D HDR^RMPRPRT,HDRH
  S (DATE,TYPE,QTY,VEN,TRANS,TRANS1,STA,SN,DEL,CST,FRM,REM)=""
Index: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m
===================================================================
--- FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m	(revision 631)
+++ FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRSP7.m	(revision 636)
@@ -1,10 +1,8 @@
 RMPRSP7 ;HIN/RVD-PRINT 2319 WITHOUT SUSPENSE LINK ;3/17/03  08:13
- ;;3.0;PROSTHETICS;**62,69,77,135**;Feb 09, 1996;Build 12
+ ;;3.0;PROSTHETICS;**62,69,77**;Feb 09, 1996
  ;RVD 8/27/01 patch #62 - PCE data print
  ;RVD 4/9/02 patch #69 -  Disregard Historical data
  ;RVD 3/17/02 patch #77 - Fixed For Loop to include all PT 2319 records
  ;                        that are not linked
- ;RGB 3/22/07 patch 135 - Modified code to check issues in 660 against file 668 suspense records
- ;                        in addition to current check of complete flag in issue record.
  ;
  D DIV4^RMPRSIT I $D(Y),(Y<0) Q
@@ -48,8 +46,5 @@
  .Q:($P(RM0,U,13)=13)!($P(RM0,U,15)="*")
  .Q:($P(RM10,U,14)>0)!($P(RM0,U,10)'=RMPR("STA"))
- .;FILTER SHIPPING CHARGES AND DDC TRANSACTIONS
- .Q:($P(RM0,U,17)'="")!($P(RM0,U,13)=16)
- .S RMIE68=$O(^RMPR(668,"F",RJ,0))
- .I RMIE68,$D(^RMPR(668,RMIE68,10,"B",RJ)) Q
+ .Q:$P(RM0,U,17)'=""
  .I $P(RM0,U,10)=RS D
  ..S RMDFN=$P(RM0,U,2)
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTOE ; GENERATED FROM 'RA ORDER EXAM' INPUT TEMPLATE(#1087), FILE 75.1;05/26/08
+RACTOE ; GENERATED FROM 'RA ORDER EXAM' INPUT TEMPLATE(#1087), FILE 75.1;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE1.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTOE1 ; ;05/26/08
+RACTOE1 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,D0,""M"",",DIC=DIE,DP=75.1125,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE2.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTOE2 ; ;05/26/08
+RACTOE2 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,D0,""M"",",DIC=DIE,DP=75.1125,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE3.m	(revision 636)
@@ -1,7 +1,7 @@
-RACTOE3 ; ;05/26/08
+RACTOE3 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(10)=% S %=$P(%Z,U,9) S:%]"" DE(16)=% S %=$P(%Z,U,12) S:%]"" DE(21)=% S %=$P(%Z,U,13) S:%]"" DE(27)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% S %=$P(%Z,U,17) S:%]"" DE(31)=% S %=$P(%Z,U,22) S:%]"" DE(18)=%
- I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE(13)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(11)=%,DE(20)=% S %=$P(%Z,U,9) S:%]"" DE(27)=% S %=$P(%Z,U,14) S:%]"" DE(9)=% S %=$P(%Z,U,22) S:%]"" DE(32)=%
+ I $D(^("R")) S %Z=^("R") S %=$P(%Z,U,1) S:%]"" DE(24)=%
  K %Z Q
  ;
@@ -80,36 +80,76 @@
  G RD:X="@",Z
 X9 Q
-10 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4
+10 S DQ=11 ;@20
+11 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4
  S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;"
  S X=RACAT
  S Y=X
  G Y
-X10 Q
-11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X11 S Y=$E(X),Y=$S(Y="R":"@30",(Y'="")&("CS"[Y):"@40",1:"@50")
+X11 Q
+12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X12 S RAX=$E(X,1),Y=$S(RAX="R":"@30","CS"[RAX:"@40",RAX="I"&($D(RAWARD))!("EO"[RAX&('$D(RAWARD))):"@50",1:"@25")
  Q
-12 S DQ=13 ;@30
-13 S DW="R;1",DV="FR",DU="",DLB="RESEARCH SOURCE",DIFLD=9.5
+13 S DQ=14 ;@25
+14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X14 I $D(RAWARD) W !?3,$C(7),"Please choose 'I' for INPATIENT, 'R' RESEARCH, 'C' CONTRACT,",!?3,"'S' SHARING!"
+ Q
+15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X15 I '$D(RAWARD) W !?3,$C(7),"Please choose 'O' for OUTPATIENT, 'E' EMPLOYEE, 'R' RESEARCH,",!?3,"'C' CONTRACT, 'S' SHARING!"
+ Q
+16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X16 D CS^RAORD1A I $D(RALIFN("OUT")) S Y="@26"
+ Q
+17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X17 I '$D(RALIFN("NO")) S Y="@50"
+ Q
+18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X18 K RALIFN("NO")
+ Q
+19 S DQ=20 ;@26
+20 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4
+ S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;"
+ S Y="@"
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+X20 Q
+21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X21 K RALIFN("OUT")
+ Q
+22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X22 S Y="@20"
+ Q
+23 S DQ=24 ;@30
+24 S DW="R;1",DV="FR",DU="",DLB="RESEARCH SOURCE",DIFLD=9.5
  S X=$S($D(RARSH):RARSH,1:"")
  S Y=X
  G Y
-X13 K:$L(X)>40!($L(X)<3) X
+X24 K:$L(X)>40!($L(X)<3) X
  I $D(X),X'?.ANP K X
  Q
  ;
-14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X14 S Y="@50"
+25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X25 S Y="@50"
  Q
-15 S DQ=16 ;@40
-16 S DW="0;9",DV="*P34'R",DU="",DLB="CONTRACT/SHARING SOURCE",DIFLD=9
+26 S DQ=27 ;@40
+27 S DW="0;9",DV="*P34'R",DU="",DLB="CONTRACT/SHARING SOURCE",DIFLD=9
  S DU="DIC(34,"
  S X=$S($D(RASHA):RASHA,1:"")
  S Y=X
  G Y
-X16 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
+X27 S DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
  Q
  ;
-17 S DQ=18 ;@50
-18 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22
+28 S DQ=29 ;@50
+29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X29 I RAX="I",($P($G(^SC(+RALIFN,0)),U,3)'="W"),($P($G(^SC(+RALIFN,0)),U,3)'="OR") S RAWHEN=$P($G(^RAO(75.1,DA,0)),U,21),RAWHEN=$S(RAWHEN]"":$P(RAWHEN,".",1),1:DT) D REQLOC1^RAORD1A
+ Q
+30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X30 I RAX="O",($P($G(^SC(+RALIFN,0)),U,3)'="C"),($P($G(^SC(+RALIFN,0)),U,3)'="OR") D REQLOC1^RAORD1A
+ Q
+31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X31 I $D(RALIFN("OUT")) K RALIFN("OUT") S Y="@999"
+ Q
+32 S DW="0;22",DV="P44'a",DU="",DLB="REQUESTING LOCATION",DIFLD=22
+ S DE(DW)="C32^RACTOE3"
  S DU="SC("
  S X=RALIFN
@@ -117,53 +157,13 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X18 Q
-19 S DQ=20 ;@100
-20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X20 W !,"IS PATIENT SCHEDULED FOR PRE-OP" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@120" I '% W !!,"Enter 'YES' if patient is scheduled for pre-op, or 'NO' if not.",! S Y="@100"
+C32 G C32S:$D(DE(32))[0 K DB
+ D ^RACTOE4
+C32S S X="" G:DG(DQ)=X C32F1 K DB
+ D ^RACTOE5
+C32F1 Q
+X32 Q
+33 S DQ=34 ;@100
+34 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=34 D X34 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X34 W !,"IS PATIENT SCHEDULED FOR PRE-OP" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@120" I '% W !!,"Enter 'YES' if patient is scheduled for pre-op, or 'NO' if not.",! S Y="@100"
  Q
-21 S DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE (TIME optional)",DIFLD=12
- S X="TODAY"
- S Y=X
- G Y
-X21 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X22 S:$D(RAEXMUL) RAPREOP1=X
- Q
-23 S DQ=24 ;@120
-24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X24 I RASEX="M" S Y="@130"
- Q
-25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X25 I RASEX'="F" W !,"THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@130" I '% W !!,"Enter 'YES' if patient is female, or 'NO' if patient is male.",! S Y="@120"
- Q
-26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X26 S RASEX="F"
- Q
-27 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13
- S DU="y:YES;n:NO;u:UNKNOWN;"
- S X=$S($D(RAPREG):$$EXTERNAL^DILFD(75.1,13,"",RAPREG),1:"")
- S Y=X
- G Y
-X27 Q
-28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X28 S RAPREG=X
- Q
-29 S DQ=30 ;@130
-30 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=30 D X30 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X30 I '$D(RAVSTFLG)!('$D(RAVLEDTI)) S Y="@135"
- Q
-31 S DW="0;17",DV="D",DU="",DLB="PAST VISIT DATE/TIME",DIFLD=17
- S X=9999999.9999-RAVLEDTI
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-X31 S %DT="TXR" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-32 S DQ=33 ;@135
-33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X33 S:$D(RAWHEN)#2 Y="@145"
- Q
-34 D:$D(DG)>9 F^DIE17 G ^RACTOE4
+35 D:$D(DG)>9 F^DIE17 G ^RACTOE6
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE4.m	(revision 636)
@@ -1,202 +1,2 @@
-RACTOE4 ; ;05/26/08
- D DE G BEGIN
-DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(8)=% S %=$P(%Z,U,6) S:%]"" DE(18)=% S %=$P(%Z,U,18) S:%]"" DE(9)=% S %=$P(%Z,U,19) S:%]"" DE(14)=% S %=$P(%Z,U,20) S:%]"" DE(26)=% S %=$P(%Z,U,21) S:%]"" DE(1)=%,DE(5)=%
- I  S %=$P(%Z,U,24) S:%]"" DE(16)=% S %=$P(%Z,U,26) S:%]"" DE(21)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="RACTOE4",DQ=1
-1 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21
- S DE(DW)="C1^RACTOE4"
- G RE
-C1 G C1S:$D(DE(1))[0 K DB
- S X=DE(1),DIC=DIE
- K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)
-C1S S X="" G:DG(DQ)=X C1F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)=""
-C1F1 Q
-X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X2 S Y="@150"
- Q
-3 S DQ=4 ;@145
-4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 G A
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21
- S DE(DW)="C5^RACTOE4"
- S X=RAWHEN
- S Y=X
- G Y
-C5 G C5S:$D(DE(5))[0 K DB
- S X=DE(5),DIC=DIE
- K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)
-C5S S X="" G:DG(DQ)=X C5F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)=""
-C5F1 Q
-X5 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-6 S DQ=7 ;@150
-7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X7 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1)
- Q
-8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5
- S DE(DW)="C8^RACTOE4"
- S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;"
- S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5)
- S Y=X
- S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-C8 G C8S:$D(DE(8))[0 K DB
- S X=DE(8),DIC=DIE
- K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)
- S X=DE(8),DIC=DIE
- ;
-C8S S X="" G:DG(DQ)=X C8F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)=""
- S X=DG(DQ),DIC=DIE
- D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X)
-C8F1 Q
-X8 Q
-9 D:$D(DG)>9 F^DIE17,DE S DQ=9,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18
- S DE(DW)="C9^RACTOE4"
- S X="NOW"
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-C9 G C9S:$D(DE(9))[0 K DB
- S X=DE(9),DIC=DIE
- K ^RAO(75.1,"AO",$E(X,1,30),DA)
-C9S S X="" G:DG(DQ)=X C9F1 K DB
- S X=DG(DQ),DIC=DIE
- S ^RAO(75.1,"AO",$E(X,1,30),DA)=""
-C9F1 Q
-X9 S %DT="TXR" D ^%DT S X=Y K:Y<1 X
- Q
- ;
-10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X10 S Y=$S('$D(^RA(79,+RADIV,.1)):"@160",$P(^(.1),"^",19)="y":"@155",1:"@160")
- Q
-11 S DQ=12 ;@155
-12 D:$D(DG)>9 F^DIE17,DE S DQ=12,D=0 K DE(1) ;75
- S DIFLD=75,DGO="^RACTOE5",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D
- I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M12
- S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
-M12 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(12)=$P(^(0),U,1)
- S X="""NOW"""
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD
-R12 D DE
- G A
- ;
-13 S DQ=14 ;@160
-14 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19
- S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;"
- S X=$S($D(RAMT):$P(RAMT,"^",2),1:"AMBULATORY")
- S Y=X
- G Y
-X14 Q
-15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X15 S:$D(RAEXMUL) RAMT=X
- Q
-16 S DW="0;24",DV="S",DU="",DLB="IS PATIENT ON ISOLATION PROCEDURES?",DIFLD=24
- S DU="y:YES;n:NO;"
- S X="NO"
- S Y=X
- G Y
-X16 Q
-17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X17 S:$D(RAEXMUL) RAIP=X
- Q
-18 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6
- S DU="1:STAT;2:URGENT;9:ROUTINE;"
- S X="ROUTINE"
- S Y=X
- G Y
-X18 Q
-19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X19 S:$D(RAEXMUL) RARU=X
- Q
-20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X20 S:$$ORVR^RAORDU()<3 Y="@163"
- Q
-21 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26
- S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;"
- S X="SERVICE CORRECTION"
- S Y=X
- G Y
-X21 Q
-22 S DQ=23 ;@163
-23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X23 W !
- Q
-24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X24 S RAREQLOC=$$ILOC^RAUTL18(RAPRI)
- Q
-25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X25 I 'RAREQLOC S Y="@165"
- Q
-26 S DW="0;20",DV="*P79.1'",DU="",DLB="IMAGING LOCATION",DIFLD=20
- S DU="RA(79.1,"
- S X=RAREQLOC
- S Y=X
- S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X26 Q
-27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X27 S Y="@170"
- Q
-28 S DQ=29 ;@165
-29 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=29 D X29 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X29 I '$D(RALOCFLG) S Y="@175"
- Q
-30 D:$D(DG)>9 F^DIE17 G ^RACTOE6
+RACTOE4 ; ;12/27/07
+ S X=DE(32),DIIX=2_U_DIFLD D AUDIT^DIET
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE5.m	(revision 636)
@@ -1,66 +1,2 @@
-RACTOE5 ; ;05/26/08
- D DE G BEGIN
-DE S DIE="^RAO(75.1,D0,""T"",",DIC=DIE,DP=75.12,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"T",DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=%
- K %Z Q
- ;
-W W !?DL+DL-2,DLB_": "
- Q
-O D W W Y W:$X>45 !?9
- I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2
- W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W "  (No Editing)" Q
-TR R X:DTIME E  S (DTOUT,X)=U W $C(7)
- Q
-A K DQ(DQ) S DQ=DQ+1
-B G @DQ
-RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
-RD G QS:X?."?" I X["^" D D G ^DIE17
- I X="@" D D G Z^DIE2
- I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W "  "_X
-T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
- K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
- G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
- I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
-V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
-X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
- S X="?BAD"
-QS S DZ=X D D,QQ^DIEQ G B
-D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q
-Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N
-PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP
-R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R
- I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R
- X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=%
-RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17
-I I DV'["I",DV'["#" G RD
- D E^DIE0 G RD:$D(X),PR
- Q
-SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1
- I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1
- D ^DIR I 'DDER S %=Y(0),X=Y
- Q
-SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
- I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
- E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
- Q
-NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
-KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
-BEGIN S DNM="RACTOE5",DQ=1
-1 S DW="0;2",DV="S",DU="",DLB="NEW STATUS",DIFLD=2
- S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;"
- S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5)
- S Y=X
- S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X1 Q
-2 S DW="0;3",DV="P200'",DU="",DLB="COMPUTER USER",DIFLD=3
- S DU="VA(200,"
- S X=DUZ
- S Y=X
- S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X2 Q
-3 G 1^DIE17
+RACTOE5 ; ;12/27/07
+ I $D(DE(32))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE6.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE6.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTOE6.m	(revision 636)
@@ -1,6 +1,6 @@
-RACTOE6 ; ;05/26/08
+RACTOE6 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,20) S:%]"" DE(1)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(21)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(7)=% S %=$P(%Z,U,17) S:%]"" DE(11)=% S %=$P(%Z,U,18) S:%]"" DE(22)=% S %=$P(%Z,U,21) S:%]"" DE(15)=%,DE(18)=%
  K %Z Q
  ;
@@ -50,21 +50,137 @@
 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="RACTOE6",DQ=1
-1 S DW="0;20",DV="*P79.1'R",DU="",DLB="SUBMIT REQUEST TO",DIFLD=20
- S DU="RA(79.1,"
- G RE
-X1 S DIC("S")="I $$SUBMIT^RAUTL13(DA,+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
+1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;12",DV="D",DU="",DLB="PRE-OP SCHEDULED DATE (TIME optional)",DIFLD=12
+ S X="TODAY"
+ S Y=X
+ G Y
+X1 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
  Q
  ;
-2 S DQ=3 ;@170
-3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X3 S:$D(RAEXMUL) RAILOC=X
+2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X2 S:$D(RAEXMUL) RAPREOP1=X
  Q
-4 S DQ=5 ;@175
+3 S DQ=4 ;@120
+4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X4 I RASEX="M" S Y="@130"
+ Q
 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X5 S (RAFIN,RAFIN1)=""
+X5 I RASEX'="F" W !,"THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE" S %=2 D YN^DICN S:%<0 Y="@999" S:%=2 Y="@130" I '% W !!,"Enter 'YES' if patient is female, or 'NO' if patient is male.",! S Y="@120"
  Q
-6 S DQ=7 ;@999
-7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X7 K RAI,RAPRI,RAMOD,RAIMAG,RAWPFLAG,RAREQLOC,RAMODPRO
+6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X6 S RASEX="F"
  Q
-8 G 0^DIE17
+7 S DW="0;13",DV="RS",DU="",DLB="PREGNANT",DIFLD=13
+ S DU="y:YES;n:NO;u:UNKNOWN;"
+ S X=$S($D(RAPREG):$$EXTERNAL^DILFD(75.1,13,"",RAPREG),1:"")
+ S Y=X
+ G Y
+X7 Q
+8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X8 S RAPREG=X
+ Q
+9 S DQ=10 ;@130
+10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X10 I '$D(RAVSTFLG)!('$D(RAVLEDTI)) S Y="@135"
+ Q
+11 S DW="0;17",DV="D",DU="",DLB="PAST VISIT DATE/TIME",DIFLD=17
+ S X=9999999.9999-RAVLEDTI
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+X11 S %DT="TXR" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;
+12 S DQ=13 ;@135
+13 S DQ=14 ;@140
+14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X14 S:$D(RAWHEN)#2 Y="@145"
+ Q
+15 S DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21
+ S DE(DW)="C15^RACTOE6"
+ G RE
+C15 G C15S:$D(DE(15))[0 K DB
+ S X=DE(15),DIC=DIE
+ K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)
+C15S S X="" G:DG(DQ)=X C15F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)=""
+C15F1 Q
+X15 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;
+16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X16 S Y="@150"
+ Q
+17 S DQ=18 ;@145
+18 D:$D(DG)>9 F^DIE17,DE S DQ=18,DW="0;21",DV="D",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21
+ S DE(DW)="C18^RACTOE6"
+ S X=RAWHEN
+ S Y=X
+ G Y
+C18 G C18S:$D(DE(18))[0 K DB
+ S X=DE(18),DIC=DIE
+ K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)
+C18S S X="" G:DG(DQ)=X C18F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)=""
+C18F1 Q
+X18 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;
+19 S DQ=20 ;@150
+20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X20 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1)
+ Q
+21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5
+ S DE(DW)="C21^RACTOE6"
+ S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;"
+ S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5)
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+C21 G C21S:$D(DE(21))[0 K DB
+ S X=DE(21),DIC=DIE
+ K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)
+ S X=DE(21),DIC=DIE
+ ;
+C21S S X="" G:DG(DQ)=X C21F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)=""
+ S X=DG(DQ),DIC=DIE
+ D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X)
+C21F1 Q
+X21 Q
+22 D:$D(DG)>9 F^DIE17,DE S DQ=22,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18
+ S DE(DW)="C22^RACTOE6"
+ S X="NOW"
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+C22 G C22S:$D(DE(22))[0 K DB
+ S X=DE(22),DIC=DIE
+ K ^RAO(75.1,"AO",$E(X,1,30),DA)
+C22S S X="" G:DG(DQ)=X C22F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S ^RAO(75.1,"AO",$E(X,1,30),DA)=""
+C22F1 Q
+X22 S %DT="TXR" D ^%DT S X=Y K:Y<1 X
+ Q
+ ;
+23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X23 S Y=$S('$D(^RA(79,+RADIV,.1)):"@160",$P(^(.1),"^",19)="y":"@155",1:"@160")
+ Q
+24 S DQ=25 ;@155
+25 D:$D(DG)>9 F^DIE17,DE S DQ=25,D=0 K DE(1) ;75
+ S DIFLD=75,DGO="^RACTOE7",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D
+ I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M25
+ S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
+M25 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(25)=$P(^(0),U,1)
+ S X="""NOW"""
+ S Y=X
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+R25 D DE
+ G A
+ ;
+26 S DQ=27 ;@160
+27 D:$D(DG)>9 F^DIE17 G ^RACTOE8
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE.m	(revision 636)
@@ -1,6 +1,6 @@
-RACTQE ; GENERATED FROM 'RA QUICK EXAM ORDER' INPUT TEMPLATE(#1086), FILE 75.1;05/26/08
+RACTQE ; GENERATED FROM 'RA QUICK EXAM ORDER' INPUT TEMPLATE(#1086), FILE 75.1;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(2)=%,DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(26)=% S %=$P(%Z,U,8) S:%]"" DE(14)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(2)=%,DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(27)=% S %=$P(%Z,U,8) S:%]"" DE(14)=%
  K %Z Q
  ;
@@ -153,5 +153,8 @@
  Q
 25 S DQ=26 ;@35
-26 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4
+26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X26 I '$D(RACAT) S RACAT="I"
+ Q
+27 S DW="0;4",DV="SX",DU="",DLB="CATEGORY OF EXAM",DIFLD=4
  S DU="I:INPATIENT;O:OUTPATIENT;C:CONTRACT;S:SHARING;E:EMPLOYEE;R:RESEARCH;"
  S X=$E(RACAT)
@@ -159,7 +162,7 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X26 Q
-27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X27 I '$D(RAPREOP1) S Y="@40"
+X27 Q
+28 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=28 D X28 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X28 I '$D(RAPREOP1) S Y="@40"
  Q
-28 D:$D(DG)>9 F^DIE17 G ^RACTQE2
+29 D:$D(DG)>9 F^DIE17 G ^RACTQE2
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE1.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTQE1 ; ;05/26/08
+RACTQE1 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,D0,""M"",",DIC=DIE,DP=75.1125,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE2.m	(revision 636)
@@ -1,6 +1,6 @@
-RACTQE2 ; ;05/26/08
+RACTQE2 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(31)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(4)=% S %=$P(%Z,U,20) S:%]"" DE(18)=%,DE(23)=%,DE(27)=% S %=$P(%Z,U,21) S:%]"" DE(11)=%,DE(14)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,3) S:%]"" DE(31)=% S %=$P(%Z,U,12) S:%]"" DE(1)=% S %=$P(%Z,U,13) S:%]"" DE(4)=% S %=$P(%Z,U,20) S:%]"" DE(18)=%,DE(23)=%,DE(27)=% S %=$P(%Z,U,21) S:%]"" DE(11)=%,DE(15)=%
  I $D(^(.1)) S %Z=^(.1) S %=$P(%Z,U,1) S:%]"" DE(7)=%
  K %Z Q
@@ -103,26 +103,27 @@
  ;
 12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X12 S Y="@560"
+X12 S RAWHEN=$$FMTE^XLFDT(X,1)
  Q
-13 S DQ=14 ;@550
-14 D:$D(DG)>9 F^DIE17,DE S DQ=14,DW="0;21",DV="DR",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21
- S DE(DW)="C14^RACTQE2"
+13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X13 S Y="@560"
+ Q
+14 S DQ=15 ;@550
+15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="0;21",DV="D",DU="",DLB="DATE DESIRED (Not guaranteed)",DIFLD=21
+ S DE(DW)="C15^RACTQE2"
  S X=RAWHEN
  S Y=X
- G Y
-C14 G C14S:$D(DE(14))[0 K DB
- S X=DE(14),DIC=DIE
+ S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD
+C15 G C15S:$D(DE(15))[0 K DB
+ S X=DE(15),DIC=DIE
  K ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)
-C14S S X="" G:DG(DQ)=X C14F1 K DB
+C15S S X="" G:DG(DQ)=X C15F1 K DB
  S X=DG(DQ),DIC=DIE
  S ^RAO(75.1,"AP",+$P(^RAO(75.1,DA,0),U),+$P(^(0),U,2),9999999.9999-$E(X,1,30),DA)=""
-C14F1 Q
-X14 S %DT="ETX" D ^%DT S X=Y K:Y<1 X
+C15F1 Q
+X15 S %DT="TX" D ^%DT S X=Y K:Y<1 X
  Q
  ;
-15 S DQ=16 ;@560
-16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X16 S:$D(RAEXMUL)#2 RAWHEN=$$FMTE^XLFDT(X,1)
- Q
+16 S DQ=17 ;@560
 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X17 I $S('$D(RAILOC):1,'RAILOC:1,1:0) S Y="@60"
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE3.m	(revision 636)
@@ -1,7 +1,7 @@
-RACTQE3 ; ;05/26/08
+RACTQE3 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,",DIC=DIE,DP=75.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RAO(75.1,DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(3)=% S %=$P(%Z,U,6) S:%]"" DE(11)=% S %=$P(%Z,U,14) S:%]"" DE(1)=% S %=$P(%Z,U,18) S:%]"" DE(4)=% S %=$P(%Z,U,19) S:%]"" DE(7)=% S %=$P(%Z,U,22) S:%]"" DE(2)=% S %=$P(%Z,U,24) S:%]"" DE(9)=%
- I  S %=$P(%Z,U,26) S:%]"" DE(13)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,5) S:%]"" DE(7)=% S %=$P(%Z,U,6) S:%]"" DE(15)=% S %=$P(%Z,U,14) S:%]"" DE(1)=% S %=$P(%Z,U,18) S:%]"" DE(8)=% S %=$P(%Z,U,19) S:%]"" DE(11)=% S %=$P(%Z,U,22) S:%]"" DE(6)=% S %=$P(%Z,U,24) S:%]"" DE(13)=%
+ I  S %=$P(%Z,U,26) S:%]"" DE(17)=%
  K %Z Q
  ;
@@ -58,5 +58,18 @@
  G RD:X="@",Z
 X1 Q
-2 S DW="0;22",DV="P44'",DU="",DLB="REQUESTING LOCATION",DIFLD=22
+2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X2 S RAX=$P(^RAO(75.1,DA,0),U,4)
+ Q
+3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X3 I RAX="I",$P($G(^SC(+RALIFN,0)),U,3)'="W",($P($G(^SC(+RALIFN,0)),U,3)'="OR") D REQLOC1^RAORD1A
+ Q
+4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X4 I RAX="O",$P($G(^SC(+RALIFN,0)),U,3)'="C",($P($G(^SC(+RALIFN,0)),U,3)'="OR") D REQLOC1^RAORD1A
+ Q
+5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X5 I $D(RALIFN("OUT")) K RALIFN("OUT") S Y="@99"
+ Q
+6 S DW="0;22",DV="P44'a",DU="",DLB="REQUESTING LOCATION",DIFLD=22
+ S DE(DW)="C6^RACTQE3"
  S DU="SC("
  S X=RALIFN
@@ -64,7 +77,12 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X2 Q
-3 S DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5
- S DE(DW)="C3^RACTQE3"
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIIX=2_U_DIFLD D AUDIT^DIET
+C6S S X="" G:DG(DQ)=X C6F1 K DB
+ I $D(DE(6))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
+C6F1 Q
+X6 Q
+7 D:$D(DG)>9 F^DIE17,DE S DQ=7,DW="0;5",DV="SX",DU="",DLB="REQUEST STATUS",DIFLD=5
+ S DE(DW)="C7^RACTQE3"
  S DU="1:DISCONTINUED;2:COMPLETE;3:HOLD;5:PENDING;6:ACTIVE;8:SCHEDULED;11:UNRELEASED;"
  S X=$S($D(RAPKG):5,$$ORVR^RAORDU()=2.5:11,1:5)
@@ -72,48 +90,48 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-C3 G C3S:$D(DE(3))[0 K DB
- S X=DE(3),DIC=DIE
+C7 G C7S:$D(DE(7))[0 K DB
+ S X=DE(7),DIC=DIE
  K ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)
- S X=DE(3),DIC=DIE
+ S X=DE(7),DIC=DIE
  ;
-C3S S X="" G:DG(DQ)=X C3F1 K DB
+C7S S X="" G:DG(DQ)=X C7F1 K DB
  S X=DG(DQ),DIC=DIE
  S ^RAO(75.1,"AS",+$P(^RAO(75.1,DA,0),U),X,DA)=""
  S X=DG(DQ),DIC=DIE
  D:$$ORVR^RAORDU()=2.5&((X=1)!(X=3)) CH^RADD2(DA,X)
-C3F1 Q
-X3 Q
-4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18
- S DE(DW)="C4^RACTQE3"
+C7F1 Q
+X7 Q
+8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;18",DV="D",DU="",DLB="LAST ACTIVITY DATE/TIME",DIFLD=18
+ S DE(DW)="C8^RACTQE3"
  S X="NOW"
  S Y=X
  S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD
-C4 G C4S:$D(DE(4))[0 K DB
- S X=DE(4),DIC=DIE
+C8 G C8S:$D(DE(8))[0 K DB
+ S X=DE(8),DIC=DIE
  K ^RAO(75.1,"AO",$E(X,1,30),DA)
-C4S S X="" G:DG(DQ)=X C4F1 K DB
+C8S S X="" G:DG(DQ)=X C8F1 K DB
  S X=DG(DQ),DIC=DIE
  S ^RAO(75.1,"AO",$E(X,1,30),DA)=""
-C4F1 Q
-X4 S %DT="TXR" D ^%DT S X=Y K:Y<1 X
+C8F1 Q
+X8 S %DT="TXR" D ^%DT S X=Y K:Y<1 X
  Q
  ;
-5 D:$D(DG)>9 F^DIE17,DE S DQ=5,D=0 K DE(1) ;75
+9 D:$D(DG)>9 F^DIE17,DE S DQ=9,D=0 K DE(1) ;75
  S DIFLD=75,DGO="^RACTQE4",DC="4^75.12DA^T^",DV="75.12D",DW="0;1",DOW="STATUS CHANGE DATE/TIME",DLB="Select "_DOW S:D DC=DC_D
- I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M5
+ I $D(DSC(75.12))#2,$P(DSC(75.12),"I $D(^UTILITY(",1)="" X DSC(75.12) S D=$O(^(0)) S:D="" D=-1 G M9
  S D=$S($D(^RAO(75.1,DA,"T",0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1)
-M5 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(5)=$P(^(0),U,1)
+M9 I D>0 S DC=DC_D I $D(^RAO(75.1,DA,"T",+D,0)) S DE(9)=$P(^(0),U,1)
  S X="""NOW"""
  S Y=X
  S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD
-R5 D DE
+R9 D DE
  G A
  ;
-6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X6 I '$D(RAMT) S RAMT="a"
+10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X10 I '$D(RAMT) S RAMT="a"
  Q
-7 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19
+11 S DW="0;19",DV="S",DU="",DLB="MODE OF TRANSPORT",DIFLD=19
  S DU="a:AMBULATORY;p:PORTABLE;s:STRETCHER;w:WHEEL CHAIR;"
  S X=$P(RAMT,"^")
@@ -121,9 +139,9 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X7 Q
-8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X8 I '$D(RAIP) S RAIP="n"
+X11 Q
+12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X12 I '$D(RAIP) S RAIP="n"
  Q
-9 S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24
+13 S DW="0;24",DV="S",DU="",DLB="ISOLATION PROCEDURES",DIFLD=24
  S DU="y:YES;n:NO;"
  S X=RAIP
@@ -131,9 +149,9 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X9 Q
-10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X10 I '$D(RARU) S RARU=9
+X13 Q
+14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X14 I '$D(RARU) S RARU=9
  Q
-11 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6
+15 S DW="0;6",DV="S",DU="",DLB="REQUEST URGENCY",DIFLD=6
  S DU="1:STAT;2:URGENT;9:ROUTINE;"
  S X=RARU
@@ -141,21 +159,21 @@
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X11 Q
-12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X12 S:$$ORVR^RAORDU()<3 Y="@80"
+X15 Q
+16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 D X16 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X16 S:$$ORVR^RAORDU()<3 Y="@80"
  Q
-13 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26
+17 S DW="0;26",DV="S",DU="",DLB="NATURE OF (NEW) ORDER ACTIVITY",DIFLD=26
  S DU="w:WRITTEN;v:VERBAL;p:TELEPHONED;s:SERVICE CORRECTION;i:POLICY;e:PHYSICIAN ENTERED;"
  S Y="s"
  S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X13 Q
-14 S DQ=15 ;@80
-15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X15 S RAFIN=1
+X17 Q
+18 S DQ=19 ;@80
+19 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=19 D X19 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X19 S RAFIN=1
  Q
-16 S DQ=17 ;@99
-17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X17 K RAI,RAPRI,RAMOD,RAIMAG,RAREQLOC,RAMODPRO
+20 S DQ=21 ;@99
+21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X21 K RAI,RAPRI,RAMOD,RAIMAG,RAREQLOC,RAMODPRO
  Q
-18 G 0^DIE17
+22 G 0^DIE17
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTQE4.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTQE4 ; ;05/26/08
+RACTQE4 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^RAO(75.1,D0,""T"",",DIC=DIE,DP=75.12,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RAO(75.1,D0,"T",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG ; GENERATED FROM 'RA REGISTER' INPUT TEMPLATE(#1083), FILE 70;05/26/08
+RACTRG ; GENERATED FROM 'RA REGISTER' INPUT TEMPLATE(#1083), FILE 70;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(",DIC=DIE,DP=70,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^RADPT(DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG1.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG1 ; ;05/26/08
+RACTRG1 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",",DIC=DIE,DP=70.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG10.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG10 ; ;05/26/08
+RACTRG10 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""L"",",DIC=DIE,DP=70.07,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"L",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG11.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG11.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG11.m	(revision 636)
@@ -1,5 +1,5 @@
-RACTRG11 ; ;05/26/08
+RACTRG11 ; ;11/06/06
  ;;
-1 N X,X1,X2 S DIXR=475 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=490 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"" D
  . D KRAD^RAPXRM(.X,.DA)
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG2.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG2 ; ;05/26/08
+RACTRG2 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))=""
@@ -106,5 +106,5 @@
  ;
 C8F1 S DIEZRXR(70.03,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=475 S DIEZRXR(70.03,DIXR)=""
+ F DIXR=490 S DIEZRXR(70.03,DIXR)=""
  Q
 X8 S DIC("S")="I $$ACTC^RACPTCSV" X ^DD(70.03,2,9.2)
@@ -144,5 +144,5 @@
  ;
 C15F1 S DIEZRXR(70.03,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=475 S DIEZRXR(70.03,DIXR)=""
+ F DIXR=490 S DIEZRXR(70.03,DIXR)=""
  Q
 X15 S DIC("S")="I $$ACTC^RACPTCSV" X ^DD(70.03,2,9.2)
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG3.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG3 ; ;05/26/08
+RACTRG3 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG4.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG4 ; ;05/26/08
+RACTRG4 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""M"",",DIC=DIE,DP=70.1,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"M",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG5.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG5 ; ;05/26/08
+RACTRG5 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""M"",",DIC=DIE,DP=70.1,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"M",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG6.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG6 ; ;05/26/08
+RACTRG6 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG7.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG7 ; ;05/26/08
+RACTRG7 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""F"",",DIC=DIE,DP=70.04,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"F",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG8.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG8 ; ;05/26/08
+RACTRG8 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",D2,""T"",",DIC=DIE,DP=70.05,DL=4,DIEL=3,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",D2,"T",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RACTRG9.m	(revision 636)
@@ -1,3 +1,3 @@
-RACTRG9 ; ;05/26/08
+RACTRG9 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^RADPT(D0,""DT"",D1,""P"",",DIC=DIE,DP=70.03,DL=3,DIEL=2,DU="" K DG,DE,DB Q:$O(^RADPT(D0,"DT",D1,"P",DA,""))=""
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADD2.m	(revision 636)
@@ -1,9 +1,4 @@
 RADD2 ;HISC/GJC/CAH-Radiology Data Dictionary Utility Routine ;5/14/97  10:31
- ;;5.0;Radiology/Nuclear Medicine;**84**;Mar 16, 1998;Build 13
- ;
- ;Integration Agreements
- ;----------------------
- ;EN^DDIOL(10142); FILE^DIE(2053);NOTE^ORX3(868);MES^XPDUTL(10141)
- ;
+ ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
 EN1(RAX,RAY) ; Input transform for the .01 field (Procedure) for the Rad/Nuc
  ; Med Common Procedure file i.e, ^RAMIS(71.3
@@ -106,14 +101,2 @@
  Q:+$P(RAUTH,"^")&($S('$P(RAUTH,"^",4):1,$P(RAUTH,"^",4)'<RADT:1,1:0)) 1
  Q 0
- ;
-PRIDXIXK(DA,X) ;This subroutine executes the KILL logic for the 'new style' AD cross-
- ;reference on the 'PRIMARY DIAGNOSTIC CODE' (data dictionary: 70.03; field: 13)
- ;Input: DA - an array where DA(2)=RADFN, DA(1)=RADTI, & DA=RACNI
- ;        X - the primary diagnostic code value (this field points to file 78.3)
- N RACNI,RADFN,RADTI,RAFDA,RAIENS,RAX
- S RADFN=DA(2),RADTI=DA(1),RACNI=DA,RAX=X ;save the variables just in case
- S RAIENS=DA_","_DA(1)_","_DA(2)_",",RAFDA(70.03,RAIENS,20)="@"
- D FILE^DIE(,"RAFDA") ;delete data in 'DIAGNOSTIC PRINT DATE' (DD: 70.03; field: 20)
- K ^RADPT("AD",RAX,RADFN,RADTI,RACNI)
- Q
- ;
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RADLQ3.m	(revision 636)
@@ -1,5 +1,4 @@
 RADLQ3 ;HISC/GJC-Delq Status/Incomplete Rpt's ;5/7/97  15:58
- ;;5.0;Radiology/Nuclear Medicine;**87**;Mar 16, 1998;Build 2
- ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 change pat ssn to display last four
+ ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
 DISPXAM ; Display exam statuses for selected Imaging Types.  These exam
  ; statuses need the 'DELINQUENT STATUS REPORT?' field tripped to
@@ -50,6 +49,4 @@
  ;       Since only inpatient and outpatient is possibly stored, any
  ;       change in the variable RAVAR will be a change to 'outpatient'.
- ; 11/15/07 BAY/KAM RA*5*87 Rem Call 217642 Added next line
- S RASSN=$E(RASSN,8,11)
  I IOM=132 D  ;132 column format
  . W !,RANME,?RATAB(1),RACN,?RATAB(2),RASSN,?RATAB(3),RADT,?RATAB(4)
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO.m	(revision 636)
@@ -1,10 +1,5 @@
 RAHLO ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97  12:13
- ;;5.0;Radiology/Nuclear Medicine;**4,8,27,55,66,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**4,8,27,55,66**;Mar 16, 1998
  ; 09/07/2005 Remedy call 108405 - KAM Allow Radiology to accept dx codes from Talk Technology
- ;
- ;Integration Agreements
- ;----------------------
- ;DT^DILF(2054); LOCK^DILF(2054); DEM^VADPT(10061); $$DT^XLFDT(10103)
- ;
 EN1 ; Check the validity of the following data globals:
  ; Example: '^TMP("RARPT-REC",$J,RASUB,' where RASUB is a
@@ -59,7 +54,5 @@
  D DT^DILF("ET",RADATE,.RAVLDT)
  S:RAVLDT=-1 RAERR="Invalid report date" Q:$D(RAERR)
- K VA,VADM,VAERR S DFN=RADFN D DEM^VADPT
- I VADM(1)']"" S RAERR="Unknown Internal patient identifier" K VA,VADM,VAERR Q
- I RASSN'=$P(VADM(2),"^") S RAERR="Internal patient identifier and SSN don't match" K VA,VADM,VAERR Q
+ K VA,VADM,VAERR S DFN=RADFN D DEM^VADPT I VADM(1)']""!(RASSN'=$P(VADM(2),"^")) S RAERR="Internal patient identifier and SSN don't match" K VA,VADM,VAERR Q
  I '$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))!(RALONGCN']"") D  Q
  . S RAERR="Invalid Exam Date and/or Case Number"
@@ -79,10 +72,10 @@
  ; check resident and staff
  N X1,X2,X3 S X2=0,X3=""
- I '$G(RATELE),+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))!(+$G(^("RASTAFF"))) D  Q:$G(RAERR)]""
+ I +$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))!(+$G(^("RASTAFF"))) D  Q:$G(RAERR)]""
  . S X1=+$G(^TMP("RARPT-REC",$J,RASUB,"RARESIDENT"))
  . I X1 D
- .. I '$D(^VA(200,"ARC","R",X1)),'$D(^VA(200,"ARC","S",X1)) S X2=1
+ .. I '$D(^VA(200,"ARC","R",X1)) S X2=1
  .. I $P($G(^VA(200,X1,"RA")),"^",3),$P(^("RA"),"^",3)'>$$DT^XLFDT S X2=X2+2
- .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as Resident or Staff"
+ .. I X2=1 S X3=$E($P($G(^VA(200,X1,0)),"^"),1,20)_" is not class'd as resident"
  .. I X2=2 S X3=$P($G(^VA(200,X1,0)),"^")_"'s INACTIVE DATE is past"
  .. I X2=3 S X3=$P($G(^VA(200,X1,0)),"^")_" is not class'd as resident and past INACTIVE DATE"
@@ -98,5 +91,5 @@
  . Q
  ; raesig is in alphanumeric format, so shouldn't use $g of it here
- I ($G(RAESIG)]"")!($G(RAVERF)) D:'$G(RATELE) VERCHK^RAHLO3 ; check if provider can verify report
+ I ($G(RAESIG)]"")!($G(RAVERF)) D VERCHK^RAHLO3 ; check if provider can verify report
  ; if verifier fails checks,
  ;   quit only if vendor is non-kurzweil,
@@ -106,7 +99,4 @@
  K RASECDX ;clear secondary dx array because RAHLO2 may not be called
  ; 09/07/2005 108405 KAM- Removed ('$D(RADENDUM)#2) from next line
- I $G(RATELE),'$D(RADENDUM),'$D(^TMP("RARPT-REC",$J,RASUB,"RADX")) D  ;Patch 84
- .I RASTAT="R" S:$D(RATELEDR) ^TMP("RARPT-REC",$J,RASUB,"RADX",1)=RATELEDR Q
- .S:$D(RATELEDF) ^TMP("RARPT-REC",$J,RASUB,"RADX",1)=RATELEDF
  D:$D(^TMP("RARPT-REC",$J,RASUB,"RADX")) DIAG^RAHLO2 Q:$D(RAERR)  ; DX code check took out - &('$D(RADENDUM)#2)
  ; edit sec Dx codes if they exist for non-addendums
@@ -119,8 +109,4 @@
  . S:'B RAERR=$$ERR^RAHLO2(A)
  . Q
- I $G(RATELE),$G(RARPT) D  Q:$D(RAERR)  ;PATCH 84
- .I $D(^RARPT(RARPT,0)) D LOCK^DILF($NA(^RARPT(RARPT))) E  S RAERR="Report: "_$P($G(^RARPT(RARPT,0)),"^")_" Locked on VISTA site" Q
- .L -^RARPT(RARPT)
- I $G(RATELE),$L($G(RATELEPI)),RATELEPI'?10N S RAERR="Incorrect Teleradiologist's NPI: "_RATELEPI Q
  D RPTSTAT^RAHLO3 ; determine the status of the report
  D FILE^RAHLO1:'$D(RAERR)
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO1.m	(revision 636)
@@ -1,13 +1,8 @@
 RAHLO1 ;HIRMFO/GJC/BNT-File rpt (data from bridge program) ;6/25/04  11:49
- ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66,87,84**;Mar 16, 1998;Build 13
- ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Correct UNDEF on null dx code
+ ;;5.0;Radiology/Nuclear Medicine;**4,5,12,17,21,27,48,55,66**;Mar 16, 1998
  ; 09/07/2005 108405 - KAM/BAY Allow Radiology to accept dx codes from Talk Technology
- ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
- ;
- ;Integration Agreements
- ;----------------------
- ;DIE(10018); ,FILE^DIE(2053); IX^DIK(10013); CREATE^WVRALINK(4793); $$NOW^XLFDT(10103)
- ;EN^XUSHSHP(10045)
- ;
+ ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx 
+ ; This routine uses the following IA:
+ ; #4793  - ^WVRALINK         (private)
 FILE ;Create Entry in File 74 and File Data
  I '$D(ZTQUEUED) N ZTQUEUED S ZTQUEUED="1^dummy to suppress screen displays in UP2^RAUTL1 and elsewhere"
@@ -17,9 +12,9 @@
  N:'$D(RAPRTSET) RAPRTSET N:'$D(RAMEMARR) RAMEMARR
  D EN2^RAUTL20(.RAMEMARR) ; 04/30/99 always recalculate RAPRTSET
- ; If the report (stub/real) exists, unverify the existing report... Else create a new report
- I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D  S RARPT=RASAV K RASAV Q:$D(RAERR)  G LOCK1
+ ; If rpt (either stub or real) exists, skip creating a new file 74 entry
+ I RARPT,$D(^RARPT(RARPT,0)) S RASAV=RARPT D FILETST^RAHLO4 Q:$D(RAERR)  D  S RARPT=RASAV K RASAV G LOCK1
  . ; must save off RARPT, RAVERF and other RA* variables because
  . ; they are being killed off somewhere in the 'Unverify A Report'
- . ; option. 'Unverify A Report' does lock the the report record in file 74!
+ . ; option.
  . N RADFN,RADTI,RACNI,RARPTSTS,RASSN,RADATE,RALONGCN,RAVERF
  . ; if report isn't a stub report, then consider it being edited
@@ -30,8 +25,7 @@
  . K ^RARPT(RARPT,"I"),^("R"),^("H")
  . Q
- ; New report logic @NEW1
+ I RAPRTSET L +^RADPT(RADFN,"DT",RADTI):0 G:$T NEW1 S RAERR="ANOTHER USER IS CURRENTLY EDITING THIS PRINTSET. TRY LATER." D KVAR Q
 NEW1 S I=$P(^RARPT(0),"^",3)
- ;since this is a new report (not linked to an exam), directly lock the new record *1 lR*
-LOCK S I=I+1 L +^RARPT(I):1 G:'$T LOCK I ($D(^RARPT(I))#2) L -^RARPT(I) G LOCK
+LOCK S I=I+1 L +^RARPT(I):1 I '$T!($D(^RARPT(I)))!($D(^RARPT("B",I))) L -^RARPT(I) G LOCK
  S ^RARPT(I,0)=RALONGCN,RARPT=I,^(0)=$P(^RARPT(0),"^",1,2)_"^"_I_"^"_($P(^(0),"^",4)+1)
  ;if case is member of a print set, then create sub-recs for file #74
@@ -39,8 +33,5 @@
  I '$D(RARPTN) N RARPTN S RARPTN=RALONGCN
  N RAXIT D PTR^RARTE2 ;create corresponding subrecs in ^RARPT()
- ;
- ;if RAERR unlock the report record (locked @LOCK), kill vars, & exit
- I $D(RAERR) D LOCKR^RAHLTCPU(.RAERR,1) D KVAR Q  ; *1 uR*
- ;
+ I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI) D KVAR Q  ;unlck & clear vars
 LOCK1 I $D(RAESIG) S X=RAESIG,X1=$G(RAVERF),X2=RARPT D EN^XUSHSHP S RAESIG=X
  K DA,DIE,DQ,DR S DA=RARPT,DIE="^RARPT("
@@ -53,6 +44,4 @@
  S DR=DR_";8////"_$S($D(RAEDIT):"",1:RADATE) ; reported date
  S DR=DR_";9////"_$S($G(RAVERF)&(RARPTSTS="V"):RAVERF,1:"") ; v'fying phys
- S:$L($G(RATELENM)) DR=DR_";9.1////"_RATELENM ;Teleradiologist name - Patch 84
- S:$L($G(RATELEPI)) DR=DR_";9.2////"_RATELEPI ;Teleradiologist NPI  - Patch 84
  S DR=DR_";11////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") ; transcriptionist
  I $G(RAVERF),(RARPTSTS="V") S DR=DR_";17////"_$G(^TMP("RARPT-REC",$J,RASUB,"RAWHOCHANGE")) ;status changed to 'verified' by
@@ -63,27 +52,11 @@
  S $P(^RARPT(RARPT,0),"^",10)=$S($D(RAESIG)&(RARPTSTS="V"):RAESIG,1:"") ; hard set because Elec Sig Code may contain a semi-colon which causes errors in DIE
  D ^DIE K DA,DR
- ;don't file a Pri. Dx code for teleradiology reports in the released status (P84v11 bus. rule)
- S RARELTEL=$S(($D(RATELE)#2)&(RARPTSTS="R"):1,1:"")
- ;
- ; 02/08/2008 GJC replaced $G w/($D(RADX)#2) p84
- ; 11/15/2007 BAY/KAM RA*5*87 Rem Call 216332 Changed next line to $G
  ; 09/07/2005 108405 KAM/BAY Removed('$D(RADENDUM)#2) from next line
- I ($D(RADX)#2),RARELTEL="" D  Q:($D(RAERR))#2
- .;now a silent FM call w/p84 due to xref being killed when stuffing an identical Dx code
- .;as the one already on file.
- .N RAFDA,RAIENS S RAIENS=RACNI_","_RADTI_","_RADFN_","
- .S RAFDA(70.03,RAIENS,13)=RADX
- .;lock the exam record, if the lock fails unlock the report record (locked @LOCK) & quit
- .D LOCKX^RAHLTCPU(.RAERR) ;*1 lE*
- .I ($D(RAERR)#2) D LOCKR^RAHLTCPU(.RAERR,1) Q  ;*1 uR*
- .K RAERR D FILE^DIE(,"RAFDA","RAERR") D LOCKX^RAHLTCPU(.RAERR,1) ;*1 uE*
- .I ($D(RAERR("DIERR"))#2) D  Q
- ..;set the error dialog; unlock the report (locked @LOCK) *1 uR*
- ..D LOCKR^RAHLTCPU(.RAERR,1) S RAERR=$G(RAERR("DIERR",1,"TEXT",1))
- ..Q
- .S:$P(^RA(78.3,+RADX,0),"^",4)="y" RAAB=1
- .Q
- ;
- K RARELTEL
+ I $D(RADX) D
+ . K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN
+ . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
+ . S DR="13////"_RADX D ^DIE K DIE,DA,DR
+ . S:$P(^RA(78.3,+RADX,0),"^",4)="y" RAAB=1
+ . Q
  ; 09/29/2005 114302 KAM/BAY Code Added to trigger alert on 2ndary dx
  I $D(RASECDX) D
@@ -98,8 +71,6 @@
  . Q:'$G(DR)
  . S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN
- . D LOCKX^RAHLTCPU(.RAERR) ;*2 lE*
  . S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
  . D ^DIE K DIE,DA,DR
- . D LOCKX^RAHLTCPU(.RAERR,1) ;*2 uE*
  . Q
  ;
@@ -146,21 +117,14 @@
  F  S RA7=$O(RAMEMARR(RA7)) Q:RA7=""  I RACNISAV'=RA7 S RACNI=RA7 D UPMEM^RAHLO4 I $D(RASECDX),('$D(RADENDUM)#2) D SECDX^RAHLO2
  S RACNI=RACNISAV
+ L -^RADPT(RADFN,"DT",RADTI) ;unlock after pce 17 is set in all cases of this printset
  ;Update Activity Log
-UPACT S DA=RARPT,DIE="^RARPT(",DR="100///""NOW""",DR(2,74.01)="2////"_$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")_";3////"_$S($G(RAVERF):RAVERF,$G(RATRANSC):RATRANSC,1:"") D ^DIE K DA,DR,DE,DQ,DIE
+UPACT S DA=RARPT,DIE="^RARPT(",DR="100///""NOW""",DR(2,74.01)="2////"_$S(RARPTSTS="V":"V",$D(RAEDIT):"E",1:"I")_";3////"_$S($G(RATRANSC):RATRANSC,$G(RAVERF):RAVERF,1:"") D ^DIE K DA,DR,DE,DQ,DIE
  ; use ix^dik to kill before setting xrefs
  S DA=RARPT,DIK="^RARPT(",RAQUEUED=1 D IX^DIK
- L -^RARPT(RARPT) ;(1 uR) conventionally unlock the report locked @LOCK
- ;
- ;If verified, update report & exam statuses; else, just update exam status
- ;Note: be careful; exam locks are executed within UP1^RAUTL1!
+ ; if verfd, update rpt & exam statuses; else, just update exam status
  I $D(RAMDV),RAMDV'="" D:RARPTSTS="V" UPSTAT^RAUTL0 D:RARPTSTS'="V" UP1^RAUTL1
- D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message
- ;
-PACS ;If there are subscribers to RA RPT xxx events broadcast ORU mesages to those subscribers
- ;via TASK^RAHLO4. If VOICE DICTATION AUTO-PRINT (#26) field is set to 'Y' print the report to
- ;the printer defined in the REPORT PRINTER NAME (#10) field via VOICE^RAHLO4.
- I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4
- ;
+ L -^RARPT(RARPT) D:'$D(RAERR)&($G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))'="KURZWEIL") GENACK^RAHLTCPB ; generate 'ACK' message
+ ; line pacs is for 2 tasks: hl7 msg'g  &  voice verified rpt printout
+PACS I ($P(^RARPT(RARPT,0),U,5)="V")!($P(^(0),U,5)="R") D TASK^RAHLO4,VOICE^RAHLO4
 KVAR K RAAB,RAEDIT,RAESIG,RAQUEUED,RARPT,RAHIST
  Q
- ;
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO2.m	(revision 636)
@@ -1,43 +1,26 @@
 RAHLO2 ;HIRMFO/GJC-File rpt (data from bridge program) ;10/30/97  09:02
- ;;5.0;Radiology/Nuclear Medicine;**55,80,84**;Mar 16, 1998;Build 13
- ;
- ;Integration Agreements
- ;----------------------
- ;$$FIND1^DIC(2051); UPDATE^DIE(2053); $$DT^XLFDT(10103); $$UP^XLFSTR(10104)
- ;
-ADENDUM ; This functions store new lines of text at the end of the existing 
- ;impression and report text. If this report is being amended through the
- ;teleradiology service, add the addendum text to the IMPRESSION TEXT (#300)
- ;field only. Note: Only ADENDUM was edited for RA*5.0*84 gjc/09.18.07
- N A,COUNTER,I,J,NODE,ROOT,SUB,X,Y
- ;NODE = ^RARPT(RARPT,"I" -or- "R"  -> where the data is to be stored...
- ;ROOT = ^TMP("RARPT-REC",$J,RASUB  -> where the addendum data resides...
- F A="I","R" D  K I,J
- .S SUB=$S(A="I":"RAIMP",1:"RATXT"),ROOT=$NA(^TMP("RARPT-REC",$J,RASUB,SUB)) Q:'$O(@ROOT@(0))
- .S NODE=$NA(^RARPT(RARPT,A))
- .S COUNTER=+$O(@NODE@($C(32)),-1) ;last record #
- .;
- .;if there is existing text, add a null line for space.
- .I '($D(I)#2),(COUNTER>0) S COUNTER=COUNTER+1,@NODE@(COUNTER,0)=$C(32),I=""
- .;
- .S Y=0 F  S Y=$O(@ROOT@(Y)) Q:'Y  D
- ..S X=@ROOT@(Y)
- ..;if addendum text is to be the original text no spacer is needed ('Addendum:' tag applied)
- ..;if prior report or impression text exist, insert a blank as a spacer
- ..;^RARPT(RARPT,"I",1,0)="original impression"
- ..;^RARPT(RARPT,"I",2,0)="" <- insert a null line as a spacer
- ..;^RARPT(RARPT,"I",3,0)="Addendum: first line of addendum" ** NOTE 'Addendum:' tag **
- ..;^RARPT(RARPT,"I",4,0)="second line of addendum"
- ..;...
- ..;^RARPT(RARPT,"I",N,0)="Nth and last line of addendum"
- ..S COUNTER=COUNTER+1
- ..;set the first line of the addendum w/header: 'Addendum: '
- ..I '($D(J)#2) S X="Addendum: "_X,J=""
- ..S @NODE@(COUNTER,0)=X
- ..Q
- .S @NODE@(0)="^^"_COUNTER_"^"_COUNTER_"^"_$$DT^XLFDT()
- .Q
+ ;;5.0;Radiology/Nuclear Medicine;**55,80**;Mar 16, 1998;Build 19
+ADENDUM ; store new lines at the end of existing text
+ F A="I","R" D
+ . I $O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) D
+ .. S RACNT=+$O(^RARPT(RARPT,A,9999999),-1),RASTRNDE=RACNT+1
+ .. ; Check if the impression an/or report text sent with the addendum
+ .. ; is to be the initial text added to the word processing multiples.
+ .. ; RASTRNDE=the first subscript where impression/report data is to
+ .. ; be stored.  If no existing impression/report text data, RASTRNDE
+ .. ; equals one.  If one & RACNT equals one, don't add a blank line
+ .. ; before adding addendum text.  If RASTRNDE & RACNT both >1, add
+ .. ; the blank line.
+ .. S I=0 F  S I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I)) Q:I'>0  D
+ ... S RACNT=RACNT+1,L=$G(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),I))
+ ... S:I=$O(^TMP("RARPT-REC",$J,RASUB,$S(A="I":"RAIMP",1:"RATXT"),0)) L="Addendum: "_L ; if the first line, append 'addendum:'
+ ... I (RASTRNDE=RACNT),(RACNT>1) S ^RARPT(RARPT,A,RACNT,0)=" ",RACNT=RACNT+1
+ ... S ^RARPT(RARPT,A,RACNT,0)=L
+ ... Q
+ .. S ^RARPT(RARPT,A,0)="^^"_RACNT_"^"_RACNT_"^"_RADATE
+ .. Q
+ . Q
+ K A,I,L,RACNT,RASTRNDE
  Q
- ;
 ERR(A) ; Invalid impression/report text message.
  ; Input: 'A' - either "I" for impression, or "R" for report
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO3.m	(revision 636)
@@ -1,17 +1,11 @@
 RAHLO3 ;HIRMFO/GJC-Process data set from the bridge program ;11/18/97  12:13
- ;;5.0;Radiology/Nuclear Medicine;**4,81,84**;Mar 16, 1998;Build 13
- ;
- ;Integration Agreements
- ;-----------------------
- ;$$GET1^DIQ(2056); $$DT^XLFDT(10103)
- ;
+ ;;5.0;Radiology/Nuclear Medicine;**4,81**;Mar 16, 1998;Build 12
 RPTSTAT ; Determine the status to set this report to.
  K RARPTSTS S:$D(RAESIG) RARPTSTS="V" Q:$D(RARPTSTS)
  ; $D(RAESIG)=0 now figure out report status
- N RASTAT S RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT")))
+ S RASTAT=$E($G(^TMP("RARPT-REC",$J,RASUB,"RASTAT")))
  I RASTAT="A" S RARPTSTS="V" Q
  I RASTAT]"",("FR"[RASTAT) D
  . S:RASTAT="F" RARPTSTS="V" Q:$D(RARPTSTS)
- . I $G(RATELE) S RARPTSTS="R" Q  ;Always allow 'Released/Unverified' reports for teleradiology
  . ; do we allow 'Released/Unverified' reports for this location?
  . S RARPTSTS=$S($P($G(^RA(79.1,RAMLC,0)),"^",17)="Y":"R",1:"D")
@@ -21,4 +15,5 @@
  ; if still no status, default to draft
  S:'$D(RARPTSTS) RARPTSTS="D"
+ K RASTAT
  Q
 TEXT(X) ; Check if the Impression Text and the Report Text contain
@@ -47,21 +42,21 @@
  ; If 'No' to any of the above questions, kill RAESIG & set the variable
  ; RAERR to the appropriate error message.
- I '$D(^VA(200,"ARC","R",+$G(RAVERF))),('$D(^VA(200,"ARC","S",+$G(RAVERF)))),'$G(RATELE) D  Q
+ I '$D(^VA(200,"ARC","R",+$G(RAVERF))),('$D(^VA(200,"ARC","S",+$G(RAVERF)))) D  Q
  . ; neither a resident or staff
  . K RAESIG S RAERR="Provider not classified as resident or staff."
  . Q
- I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)),'$G(RATELE) D  Q
+ I $D(^VA(200,"ARC","R",+$G(RAVERF))),('$P(RAMDV,"^",18)) D  Q
  . ; residents can't verify reports linked to this division
  . K RAESIG S RAERR="Residents are not permitted to verify reports."
  . Q
- I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))),'$G(RATELE) D  Q
+ I '$D(^XUSEC("RA VERIFY",+$G(RAVERF))) D  Q
  . ; verifier MUST have the RA VERIFY key.
  . K RAESIG S RAERR="Provider does not meet security requirements to verify report."
  . Q
- I '$G(RATELE),$P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D
+ I $P($G(^VA(200,+$G(RAVERF),"RA")),"^",3),($P(^("RA"),"^",3)'>$$DT^XLFDT()) D
  . ; Rad/Nuc Med user has been inactivated.
  . K RAESIG S RAERR="Inactive Rad/Nuc Med Classification for Interpreting Physician."
  . Q
- I '$G(RATELE),'$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D
+ I '$S('$D(^VA(200,+$G(RAVERF),"RA")):1,$P(^("RA"),"^")'="Y":1,1:0) D
  . K RAESIG S RAERR="Staff review required to verify report."
  . Q
@@ -94,8 +89,7 @@
  . I RAVCNT=1,('$D(RAVIEN(RAVCNT))#2) S RAVIEN(RAVCNT)=RAVIEN
  . Q
- I RAVCNT=0 S RAERR="Invalid Provider Name: "_RAVERF Q  ; partial match not found
- I RAVCNT>1 S RAERR="Non-Unique Provider Name: "_RAVERF Q  ; >1 partial match
- ;S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error"
- S:'$G(RAVIEN(1)) RAERR="Provider Name Entry Error: "_RAVERF S RAVERF=$G(RAVIEN(1))
+ I RAVCNT=0 S RAERR="Invalid Provider Name" Q  ; partial match not found
+ I RAVCNT>1 S RAERR="Non-Unique Provider Name" Q  ; >1 partial match
+ S RAVERF=$G(RAVIEN(1)) S:'RAVERF RAERR="Provider Name Entry Error"
  Q
 ESIG ; Added for COTS E-Sig capability
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m	(revision 636)
@@ -1,14 +1,7 @@
 RAHLO4 ;HIRMFO/GJC-File rpt (data from bridge program) ;7/21/99  11:45
- ;;5.0;Radiology/Nuclear Medicine;**4,8,81,84**;Mar 16, 1998;Build 13
- ;
- ;Integration Agreements
- ;----------------------
- ;NOW^%DTC(10000); %ZTLOAD(10063); FIND^DIC(2051); ^DIE(10018); ^DIK(10013); $$GET1^DIQ(2056)
- ;GETS^DIQ(2056); ^XMD(10070)
- ;
+ ;;5.0;Radiology/Nuclear Medicine;**4,8,81**;Mar 16, 1998;Build 12
 TASK ; Task ORU message
  S ZTDESC="Rad/Nuc Med Compiling HL7 ORU Message",ZTDTH=$H,ZTIO="",ZTRTN="RPT^RAHLRPC",ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RARPT")=""
- ;Next line of coding will assure that ORU (report) message will be sent after posible ORM message. (10 second)
- S $P(ZTDTH,",",2)=$P(ZTDTH,",",2)+4 S:$P(ZTDTH,",",2)>86400 ZTDTH=$P(ZTDTH,",")+1_","_($P(ZTDTH,",",2)-86400)
+ ;S:$L($G(RANOSEND))&'$O(RAPRSET(RADTI,0)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD
  S:$L($G(RANOSEND)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD
  K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
@@ -22,5 +15,8 @@
  D ^%ZTLOAD K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH
  Q
- ;
+FILETST ; is anyone else working on this report?
+ L +^RARPT(RARPT):1
+ I '$T S RAERR="This report is being edited by another user" L -^RARPT(RARPT)
+ Q
 UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set
  ; first clear those fields
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLR.m	(revision 636)
@@ -1,4 +1,4 @@
 RAHLR ;HISC/CAH/BNT - Generate Common Order (ORM) Message ;11/10/99  10:42
- ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,71,82,75,80**;Mar 16, 1998;Build 19
  ;Generates msg whenever a case is registered or cancelled or examined
  ;              registered        cancelled        examined
@@ -6,15 +6,4 @@
  ; Order status  : IP                CA               CM
  ;02/14/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R
- ;
- ;Integration Agreements
- ;----------------------
- ;NOW^%DTC(10000); ^%ZTLOAD(10063); $$GET1^DIQ(2056); ^DIWP(10011)
- ;$$HLDATE/$$HLNAME/$$M11^HLFNC(10106); INIT^HLFNC2(2161)
- ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$EN^VAFHLPID(263)
- ;$$FMTHL7^XLFDT(10103)
- ;
- ;IA: 10039 global read .01 field WARD LOCATION (#42) file ^DIC(42,
- ;IA: 10040 global read .01 field HOSPITAL LOCATION (#44) file ^SC(
- ;
  S:$D(HLNDAP) ZTSAVE("HLNDAP")="" S:$D(HLDAP) ZTSAVE("HLDAP")="" S:$D(RAEXMDUN) ZTSAVE("RAEXMDUN")=""
  S:$D(RAEXEDT) ZTSAVE("RAEXEDT")=""
@@ -36,7 +25,7 @@
  ;RAEXMDUN passed from EXM^RAHLRPC if conditions are met
  Q:+$G(HL)=15  ;no known client(item) linked to the event driver protocol
- Q:$O(HL(""))=""  ;disabled server appl, or no server appl 
+ Q:$O(HL(""))=""  ;disabled server appl, or no server appl
  ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
- I HL("VER")>2.3,($T(^RAHLR1))'="" D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q
+ ;I HL("VER")]2.3 D EN^RAHLR1(RADFN,RADTI,RACNI,RAEID) Q
  ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
  S RACN0=$S($D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)):^(0),1:"") Q:RACN0']""
@@ -47,5 +36,5 @@
  S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9),RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT)
  ;RA*5*82 RAEXEDT= Override the EXM conditions if Case edited
- ;I $G(RAEXMDUN)=1,'$G(RAEXEDT),$P(RACN0,U,30)'="",'$G(RATELE) Q  ;last chance to stop exm'd msg if it's already been sent RA*5*84 Is TELERAD ?? 
+ I $G(RAEXMDUN)=1,'$G(RAEXEDT),$P(RACN0,U,30)'="" Q  ;last chance to stop exm'd msg if it's already been sent
  ;Compile 'PID' Segment
  K VA,VADM,VAERR,RAVADM S DFN=RADFN D DEM^VADPT I VADM(1)']"" S HLP("ERRTEXT")="Invalid Patient Identifier" G EXIT
@@ -73,8 +62,5 @@
  ; S RAOBR4=$P(RACPTNDE,U)_$E(HLECH)_$$ESCAPE^RAHLRU($P(RACPTNDE,U,2))_$E(HLECH)_"C4"_$E(HLECH)_+RAPROC_$E(HLECH)_$$ESCAPE^RAHLRU($P(RAPRCNDE,U))_$E(HLECH)_"99RAP"
  I $P(RACPTNDE,U)']"" S $P(RAOBR4,$E(HLECH),1,3)=$P(RAOBR4,$E(HLECH),4,5)_$E(HLECH)_"LOCAL"
- ;OBR-7 change: from HLDT1 to $$HLDATE^HLFNC(9999999.9999-RADTI) d/t of registration
- ;Driver of change: CareStream Health PACS. Agfa requires a timestamp down to the second
- ;POC @ Boston is Maureen Sullivan
- S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_$$HLDATE^HLFNC(9999999.9999-RADTI)
+ S HLA("HLS",3)="OBR"_HLFS_HLFS_RADTE_HLFS_RADTI_"-"_RACNI_$E(HLECH)_RADTE_$E(HLECH)_"L"_HLFS_RAOBR4_HLFS_HLFS_HLFS_HLDT1
  S HLA("HLS",3)=HLA("HLS",3)_HLFS_HLQ_HLFS_HLQ_HLFS_HLFS_HLFS_HLFS_HLFS_HLQ_HLFS_HLFS
  S RAPRV=$$GET1^DIQ(200,+$P(RACN0,"^",14),.01)
@@ -126,6 +112,5 @@
  N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
  S HLEID=EID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I"
- D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX")
- D:$D(RASSSX1(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX1")
+ D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP)
  D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
  Q
@@ -134,10 +119,9 @@
 INIT ; initialize HL7 variables
  D NOW^%DTC S HLDT=%,HLDT1=$$HLDATE^HLFNC(%)
- ;Note: HLDT1 is used for HL7 fields: ORC-9 & OBR-22
  Q:'$G(RAEID)  S EID=RAEID
  S HL="HLS(""HLS"")",INT=1
  D INIT^HLFNC2(EID,.HL,INT)
  Q:'$D(HL("Q"))  ;no server application defined
- S HLQ=HL("Q")
+ S HLQ=HL("Q"),HLFS=HL("FS")
  S HLECH=HL("ECH")
  S HLFS=HL("FS")
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPC.m	(revision 636)
@@ -1,33 +1,26 @@
 RAHLRPC ;HIRMFO/BNT-Rad/NM HL7 Protocol calls ;05/21/99   14:50
- ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**12,25,54,71,82,81**;Mar 16, 1998;Build 12
  ; 03/16/2006 *71 Rem Call 124379 allow exam updates to create HL7 msg
- ;
- ;Integration Agreements
- ;----------------------
- ;$$FIND1^DIC(2051); GETS^DIQ(2056)
- ;all access to ^ORD(101 to maintain application specific protocols(872)
- ;read w/FileMan HL7 APPLICATION PARAMETER(10136)
- ; 
 REG ; register exam
- N X,RA101Z,RAEID
- S RA101Z="RA REF" ; get all protocols beginning RA REG
- F  S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA REG"  D
- .S RAEID=$O(^ORD(101,"B",RA101Z,0))
+ N X,RAPID,RAEID
+ S RAPID="RA REF" ; get all protocols beginning RA REG
+ F  S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA REG"  D
+ .S RAEID=$O(^ORD(101,"B",RAPID,0))
  .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
  Q
 CANCEL ; cancel exam
- N X,RA101Z,RAEID
- S RA101Z="RA CANCEK" ; get all protocols beginning RA CANCEL
- F  S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA CANCEL"  D
- .S RAEID=$O(^ORD(101,"B",RA101Z,0))
+ N X,RAPID,RAEID
+ S RAPID="RA CANCEK" ; get all protocols beginning RA CANCEL
+ F  S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA CANCEL"  D
+ .S RAEID=$O(^ORD(101,"B",RAPID,0))
  .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
  Q
  ;
 RPT ; report verified or released/not verified
- N X,RA101Z,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA
+ N X,RAPID,RAEID,RASSS ; RASSS subcriber array to be passed to HLL for GENERATE^HLMA
  ;S X="^%ET",@^%ZOSF("TRAP")
- S RA101Z="RA RPS" ; get all protocols beginning RA RPT
- F  S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA RPT"  D
- .S RAEID=$O(^ORD(101,"B",RA101Z,0)) K RASSS  ; RA*5*81
+ S RAPID="RA RPS" ; get all protocols beginning RA RPT
+ F  S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA RPT"  D
+ .S RAEID=$O(^ORD(101,"B",RAPID,0)) K RASSS  ; RA*5*81
  .S:$L($G(RANOSEND)) RAEID=$$GETEID(RAEID,RANOSEND,.RASSS) ;RA*5*81
  .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLRPT
@@ -51,7 +44,6 @@
  ; RAEXEDT = Indication of editing of: proc, proc mod, req phys, CPT mod, Tech comm...
  ; RAGENHL7 = Indication that sending ORU is due...
- ; RASSSX1(IENs) = Array of subscribers from 771, the message will be sent (SCIMGE)
  ; 
- N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7,RASSSX1
+ N RAIMGTYI,RAIMGTYJ,RALOWER,RANEWST,RAEXMDUN,RAGENHL7
  S RAIMGTYI=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2),RAIMGTYJ=$P(^RA(79.2,RAIMGTYI,0),U),RANEWST=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)),U,3)
  S:$P(^RA(72,RANEWST,0),U,8)="Y" RAGENHL7=1 ;this status has GEN HL7 marked Y
@@ -61,15 +53,12 @@
  ;?? none of the lower status levels have GEN HL7 marked Y
  K:$P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y" RAGENHL7 ;already sent
- ;Q:'$G(RAEXEDT)&'$G(RAGENHL7)
- ; Business Rule: RA*5*84 sends an examined message to ScImage unconditionally
- I '$G(RAEXEDT),'$G(RAGENHL7) Q:'$O(^RA(79.7,0))  D  Q:'$O(RASSSX1(0))
- .N X,RASSS,RASSSL S X=0 F  S X=$O(^RA(79.7,X)) Q:'X  S:$P(^(X,0),U,2) RASSS(X)=""
- .D:$D(RASSS) GETSUB^RAHLRS1(.RASSS,.RASSSX1,.RASSSL)
+ Q:'$G(RAEXEDT)&'$G(RAGENHL7)
+ ;
 1 N RAEXMDUN
  S RAEXMDUN=1
-A1 N X,RA101Z,RAEID
- S RA101Z="RA EXAMINEC" ; get all protocols beginning RA EXAMINED
- F  S RA101Z=$O(^ORD(101,"B",RA101Z)) Q:RA101Z'["RA EXAMINED"  D
- .N RAGENHL7 S RAEID=$O(^ORD(101,"B",RA101Z,0))
+A1 N X,RAPID,RAEID
+ S RAPID="RA EXAMINEC" ; get all protocols beginning RA EXAMINED
+ F  S RAPID=$O(^ORD(101,"B",RAPID)) Q:RAPID'["RA EXAMINED"  D
+ .N RAGENHL7 S RAEID=$O(^ORD(101,"B",RAPID,0))
  .I RAEID,'$L($P(^ORD(101,RAEID,0),"^",3)) D EN^RAHLR
  S:$G(RAGENHL7) $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),U,30)="Y"
@@ -82,7 +71,6 @@
  ; 0 (zero) returned if No subscriber exist or all subscribers associated with RANOSEND application.
  S RAEID=$G(RAEID) Q:'RAEID!'$L($G(RANOSEND))!'$D(^ORD(101,+RAEID,0)) RAEID
- N RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS,DIERR,RAERR
- S RAPL=$S(+RANOSEND:+RANOSEND,1:$$FIND1^DIC(771,"","X",RANOSEND,"","","RAERR"))
- Q:'RAPL!($D(RAERR)#2) RAEID
+ N RAXX,ERR,X1,Y1,YY,RAPL,RANEW,RAPIDS,RAIEDS
+ S RAPL=$S(+RANOSEND:+RANOSEND,1:$O(^HL(771,"B",RANOSEND,0))) Q:'RAPL RAEID
  D GETS^DIQ(101,RAEID_",","**","I","RAXX","ERR")
  Q:$D(ERR) RAEID ; Was not able get Event driver info... so just pass event driver...
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRPT.m	(revision 636)
@@ -1,4 +1,4 @@
 RAHLRPT ;HISC/CAH AISC/SAW-Compiles HL7 'ORU' Message Type ; 4/26/01 10:40am
- ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**2,12,10,25,81,80**;Mar 16, 1998;Build 19
 EN ; Called from RA RPT and RA RPT 2.3 protocol entry action
  ; Input variables:
@@ -10,17 +10,9 @@
  ; Output variables:
  ;   HLA("HLS", array containing HL7 msg
- ;   RATELREL = 1  Indicates that the text: 'Released for local dictation by National Teleradiology'
- ;              has been included in Impression or Report section
- ;   RATELX =   Text used as indication of Release for local dictation... if not set use defauld above...
- ;   RATELE =   1 If RANOSEND is Teleradiology type vendor
  ;
- ;Integration Agreements
- ;----------------------
- ;$$GET1^DIQ(2056); ^DIWP(10011); $$HLDATE/$$HLNAME^HLFNC(10106)
- ;GENERATE^HLMA(2164); DEM^VADPT(10061); $$FMTHL7^XLFDT(10103)
- ;$$PATCH^XPDUTL(10141); $$VERSION^XPDUTL(10141)
- ;
- N RASET,RACN0,RATELE,RATELREL,RATELX
- D INIT^RAHLRPTT ;Patch 84
+ N RASET,RACN0
+ S RASET=0
+ S RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
+ S:'$D(RARPT) RARPT=+$P(RACN0,"^",17)
  I +$P(RACN0,U,25)=2 D  Q  ; printset
  .; loop through all cases in set and create message
@@ -37,8 +29,8 @@
  D INIT^RAHLRU ;initialize HL7 variables
  Q:+$G(HL)=15  ;no known client(item) linked to the event driver protocol
- Q:$O(HL(""))=""  ;failed return from INIT^HLFNC2 (called by INIT^RAHLRU)
+ Q:$O(HL(""))=""  ;failed return from init^hlfnc2
  ;
  ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
- I HL("VER")>2.3,($T(^RAHLRPT1))'="" D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q
+ ;I HL("VER")]2.3 D EN^RAHLRPT1(RADFN,RADTI,RACNI,RAEID),EXIT Q
  ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
  ;
@@ -49,13 +41,11 @@
  ; for an inexact date of birth.  If inexact, pass null for DOB in
  ; the 'PID' segment.  Some COTS systems can't handle inexact DOB's.
- D SETUP^RAHLRPTT,PID^RAHLRPTT,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM
+ D SETUP,PID,OBR,OBXPRC,OBXIMP,OBXDIA,OBXRPT,OBXMOD,OBXTCM
 EXIT ; set HL7 message type & return to RA RPT protocol
- ;For P84 see if this is a >>Released for local reading<< type report and if yes resend the ORM (^RAHLRS1)...
- I $G(RATELREL) D RESEND^RAHLRPTT(RADFN,RADTI,RACNI) Q  ;P84 resend in the case that report released from Telerad
  S HL("MTN")="ORU"
  N HLEID,HLARYTYP,HLFORMAT,HLMTIEN,HLP
  S HLEID=RAEID,HLARYTYP="LM",HLFORMAT=1,HLMTIEN="",HLP("PRIORITY")="I"
  M:$D(RASSS) HLP=RASSS
- D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP,"RASSSX")
+ D:$D(RASSSX(HLEID)) GETHLP^RAHLRS1(HLEID,.HLP)
  D GENERATE^HLMA(HLEID,HLARYTYP,HLFORMAT,.HLRESLT,HLMTIEN,.HLP)
  K RAVADM
@@ -102,5 +92,5 @@
  S $P(X1,HLFS,35)="" I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) D
  .S X2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0)) I X2']"" Q
- .S X2=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)),"^",1) I X2']"" Q
+ .S X2=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",X2,0)) I X2']"" Q
  .S XX2=$$GET1^DIQ(200,X2,.01) Q:XX2']""
  .S Y=$$HLNAME^HLFNC(XX2) I Y']"" Q
@@ -108,10 +98,10 @@
  ;Transcriptionist
  S $P(X1,HLFS,36)="" I $G(^RARPT(RARPT,"T")) D
- .S X2=$$GET1^DIQ(200,$P(^RARPT(RARPT,"T"),"^",1),.01) I X2']"" Q
+ .S X2=$$GET1^DIQ(200,^RARPT(RARPT,"T"),.01) I X2']"" Q
  .S Y=$$HLNAME^HLFNC(X2) I Y']"" Q
  .S $P(X1,HLFS,36)=^RARPT(RARPT,"T")_$E(HLECH)_Y
  ;
  ; if long str, break so 2nd str begins with separator to avoid abend
- N RAPART I $L(X1)>245 F RAPART=5:1:18 S RAPART(1)=$P(X1,HLFS,1,RAPART),RAPART(2)=$P(X1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="")
+ I $L(X1)>245 N RAPART F RAPART=5:1:18 S RAPART(1)=$P(X1,HLFS,1,RAPART),RAPART(2)=$P(X1,HLFS,RAPART+1,99) Q:$L(RAPART(1))<245&($L(RAPART(2))<245)&($P(RAPART(2),HLFS)="")
  I $D(RAPART) K:RAPART=18 RAPART ;if RAPART reaches 18, then something's wrong, so kill RAPART to allow abend due "string too long"
  S RAN=RAN+1
@@ -146,6 +136,5 @@
 OBXIMP ;Compile 'OBX' segment for Impression
  I '$O(^RARPT(RARPT,"I",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q
- K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1
- F RAI=0:0 S RAI=$O(^RARPT(RARPT,"I",RAI)) Q:'RAI  I $D(^(RAI,0)) S X=^(0) D RATELREL,^DIWP
+ K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"I",RAI)) Q:'RAI  I $D(^(RAI,0)) S X=^(0) D ^DIWP
  F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI  I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"I"_$E(HLECH)_"IMPRESSION"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU
  Q
@@ -156,16 +145,26 @@
  S RAN=RAN+1 D OBXPRC^RAHLRU
  Q
-OBXTCM ;Compile 'OBX' Segment for Tech Comments
+OBXTCM ; Compile 'OBX' Segment for Tech Comments
  D OBXTCM^RAHLRU
  Q
 OBXRPT ;Compile 'OBX' Segment for Radiology Report Text
  I '$O(^RARPT(RARPT,"R",0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_"None Entered" D OBX11^RAHLRU Q
- K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1
- F RAI=0:0 S RAI=$O(^RARPT(RARPT,"R",RAI)) Q:'RAI  I $D(^(RAI,0)) S X=^(0) D RATELREL,^DIWP
+ K ^UTILITY($J,"W") S DIWF="",DIWR=80,DIWL=1 F RAI=0:0 S RAI=$O(^RARPT(RARPT,"R",RAI)) Q:'RAI  I $D(^(RAI,0)) S X=^(0) D ^DIWP
  F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI  I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_^(0) D OBX11^RAHLRU
  ; Replace above with following when Imaging can cope with ESC chars
  ; F RAI=0:0 S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI  I $D(^(RAI,0)) S RAN=RAN+1,HLA("HLS",RAN)="OBX"_HLFS_HLFS_"TX"_HLFS_"R"_$E(HLECH)_"REPORT"_$E(HLECH)_"L"_HLFS_HLFS_$$ESCAPE^RAHLRU(^(0)) D OBX11^RAHLRU
  Q
-RATELREL ;Release the study for local reading
- I $G(RATELE),X[$G(RATELX) S RATELREL=1 Q
- ; 
+PID ;Compile 'PID' Segment
+ I HL("VER")']"2.2" D
+ .S X1="",X1="PID"_HLFS_HLFS_$G(VA("PID"))_HLFS_Y_HLFS_HLFS S X=VADM(1),Y=$$HLNAME^HLFNC(X) S X1=X1_Y_HLFS_HLFS
+ .S X=RAVADM(3),Y=$$HLDATE^HLFNC(X) S X1=X1_Y_HLFS_$S(VADM(5)]"":$S("MF"[$P(VADM(5),"^"):$P(VADM(5),"^"),1:"O"),1:"U") S:$P(VADM(2),"^")]"" $P(X1,HLFS,20)=$P(VADM(2),"^") S RAN=RAN+1,HLA("HLS",RAN)=X1
+ I HL("VER")]"2.2" S RAN=RAN+1,HLA("HLS",RAN)=$$EN^VAFHLPID(DFN,"2,3,5,7,8,19,20")
+ Q
+SETUP ; Setup basic examination information
+ S:RASET RACN0=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
+ S RADTE0=9999999.9999-RADTI,RADTECN=$E(RADTE0,4,7)_$E(RADTE0,2,3)_"-"_+RACN0,RARPT0=^RARPT(RARPT,0)
+ S RAPROC=+$P(RACN0,U,2),RAPROCIT=+$P($G(^RAMIS(71,RAPROC,0)),U,12),RAPROCIT=$P(^RA(79.2,RAPROCIT,0),U,1)
+ S RAPRCNDE=$G(^RAMIS(71,+RAPROC,0)),RACPT=+$P(RAPRCNDE,U,9)
+ S RACPTNDE=$$NAMCODE^RACPTMSC(RACPT,DT)
+ S Y=$$HLDATE^HLFNC(RADTE0) S RADTE0=$S(Y:Y,1:HLQ),Y=$$M11^HLFNC(RADFN)
+ Q
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLRS1.m	(revision 636)
@@ -1,12 +1,6 @@
 RAHLRS1 ;HIRMFO/ROB/PAVEL - Resend HL7 messages for selected Timeframe ; 4/2/07 3:42pm
- ;;5.0;Radiology/Nuclear Medicine;**80,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**80**;Mar 01, 2007;Build 19
+ ;
  ; Utility to RESEND HL7 messages for selected Timeframe
- ;
- ;Integration Agreements
- ;----------------------
- ;^%DT(10003); C^%DTC(10000); H^%DTC(10000); ^%ZISC(10089); ^%ZTLOAD(10063); $$GET1^DIQ(2056)
- ;^DIR(10026); ^XMD(10070)
- ;all access to ^ORD(101 to maintain application specific protocols(872)
- ;read w/FileMan HL7 APPLICATION PARAMETER(10136)
  ;
  N RACNI,RADFN,RADTI,RARPT,X,RAED,RABD,RASHBD,RASHED,RASHTD,RASHTM,DIC,DA,XX,YY
@@ -30,10 +24,9 @@
  S RAED=RAED_"."_9999
  K XX G:'$$GETAP(.XX) STOP
- W !!,"*** Pick the application in which to send the radiology data ***",!!
+ W !!,"****Pick the application to send the RAD data to*****",!!
  F I=1:1 Q:'$D(XX(I))  W !,"  #",I,"   ",$O(XX(I,""))
-2 ;user selects the application
- S DIR(0)="N^1:"_(I-1)
- W ! S DIR("?")="Please select an available application from the list."
- D ^DIR Q:$D(DIRUT)
+2 S DIR(0)="N"
+ W ! S DIR("?")="Please select an available application from the list"
+ D ^DIR Q:$D(DIRUT)  I (X'<1),(X'<I) W "Please select an available application from the list" G 2
  W !!,"The: ",$O(XX(+X,"")),"   will be the recipient"
  W !!,"Reviewing exams for selected time period... (This may take a few minutes)... "
@@ -53,13 +46,13 @@
  W !,"Task ",$S('$D(ZTSK):" Has Not been Tasked !!!",1:"#:"_ZTSK_" Has been Tasked")
  D:$D(ZTSK)
- .N RAX,RAMPG,XMSUB,XMY,XMTEXT
- .S RAX(1)="Task #"_$G(ZTSK)_" is scheduled to run the option: "
- .S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
- .S RAX(3)=" Scheduled time to run: "_RASHTM
- .S RAX(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)
+ .N X,RAMPG,XMSUB,XMY,XMTEXT
+ .S X(1)="Task #"_$G(ZTSK)_" is scheduled to run the option: "
+ .S X(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
+ .S X(3)=" Scheduled time to run: "_RASHTM
+ .S X(4)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)
  .S XMSUB="TASKMAN SCHEDULE NOTIFICATION/INFO"
  .S RAMPG="G.RAD HL7 MESSAGES"
  .S XMY(RAMPG)="",XMDUZ=.5
- .S XMTEXT="RAX("
+ .S XMTEXT="X("
  .D ^XMD
  Q
@@ -72,14 +65,14 @@
  ..S RADTI=0 F  S RADTI=$O(^RADPT("AR",RABD,RADFN,RADTI)) Q:'RADTI  D
  ...S RACNI=0 F  S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI  D RESEND(RADFN,RADTI,RACNI)
- K RAX S RAX(1)="Task #"_$G(ZTSK)_" successfully completed the option: "
- S RAX(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
- S RAX(3)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)
- S RAX(4)="# Of RAD Reports transferred: "_$G(RASUM7R)
- S RAX(5)="# Of Exams transferred:      "_$G(RASUM7)
+ K X S X(1)="Task #"_$G(ZTSK)_" successfully completed the option: "
+ S X(2)=">>Re-send HL7 messages for a date range and for designated Recipient.<<"
+ S X(3)="Date range from: "_$G(RASHBD)_" to: "_$G(RASHED)
+ S X(4)="# Of RAD Reports transferred: "_$G(RASUM7R)
+ S X(5)="# Of Exams transferred:      "_$G(RASUM7)
  S:$G(RASUM7E) X(6)="# Of Exams not transferred because of ""BAD DATA"": "_$G(RASUM7E)
  S XMSUB="TASKMAN ""RESEND HL7 OPTION"" COMPLETED/INFO"
  S RAMPG="G.RAD HL7 MESSAGES"
  S XMY(RAMPG)="",XMDUZ=.5
- S XMTEXT="RAX("
+ S XMTEXT="X("
  D ^XMD
  G STOP
@@ -88,21 +81,21 @@
 RESEND(RADFN,RADTI,RACNI) ; re-send exam message(s) to HL7 subscribers
  ; for every 10 messages sent, make sure queue is not clogged... $$HANG
- N RAXAMP80 S RAXAMP80=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- I '(+$P(RAXAMP80,U))!'($P(RAXAMP80,U,2)) S RASUM7E=RASUM7E+1 Q
- N RABD,RAEDP80,QUIT
+ I '(+^(RACNI,0)) S RASUM7E=RASUM7E+1 Q
+ I '$P(^(0),U,2) S RASUM7E=RASUM7E+1 Q
+ N RABD,RAED,QUIT
  ;
  I '$D(DT) D ^%DT S DT=Y
  ;
- S RAEDP80=$$RAED(RADFN,RADTI,RACNI)
- I '$L(RAEDP80) S RASUM7E=RASUM7E+1 Q
- D:RAEDP80[",REG,"
+ S RAED=$$RAED(RADFN,RADTI,RACNI)
+ I '$L(RAED) S RASUM7E=RASUM7E+1 Q
+ D:RAED[",REG,"
  .D CHSUM N RASUM7,RASUM7R,RASUM7E D REG^RAHLRPC
- D:RAEDP80[",CANCEL,"
+ D:RAED[",CANCEL,"
  .D CHSUM N RASUM7,RASUM7R,RASUM7E D CANCEL^RAHLRPC
- D:RAEDP80[",EXAM,"
+ D:RAED[",EXAM,"
  .D CHSUM
  .S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",30)="" ;Reset sent flag
  .N RASUM7,RAEXMDUN,RASUM7R,RASUM7E D 1^RAHLRPC
- D:RAEDP80[",RPT,"
+ D:RAED[",RPT,"
  .D CHSUM N RASUM7,RANOSEND,RASUM7R,RASUM7E,RARPT D RPT^RAHLRPC
  Q
@@ -153,11 +146,6 @@
  .F  S X1=$O(^ORD(101,"B",X1)) Q:X1'[X11  S X2=$O(^ORD(101,"B",X1,0)) Q:'X2  D
  ..K Z S X3=0 F  S X3=$O(^ORD(101,X2,775,X3)) Q:'X3  S Z(+^(X3,0))=""
- ..Q:'$D(Z)  K Z1 S X3=0 F  S X3=$O(Z(X3)) Q:'X3  D
- ...S Z1=$G(^ORD(101,X3,770)) S:+$P(Z1,U,2) XXX(+$P(Z1,U,2))=""
- S X1=0 F J=1:1 S X1=$O(XXX(X1)) Q:'X1  D
- .N DIERR,RAERR,Y
- .S Y=$$GET1^DIQ(771,X1,.01,"","","RAERR")
- .Q:Y=""!($D(RAERR)#2)  S XX(J,Y)=X1
- .Q
+ ..Q:'$D(Z)  K Z1 S X3=0 F  S X3=$O(Z(X3)) Q:'X3  S XXX(+$P($G(^ORD(101,X3,770)),U,2))=""
+ S X1=0 F J=1:1 S X1=$O(XXX(X1)) Q:'X1  S XX(J,$P(^HL(771,X1,0),U))=X1
  Q $S($D(XXX):1,1:0)
  ;
@@ -176,10 +164,7 @@
  ...S XX=+$P($G(^ORD(101,XX,770)),U,7) S:XX LINK(XX)=""
  Q
-GETHLP(RAEID,HLP,ADR) ; Get excluded subcribers set into HLP array
- N I,J,XX,AA S J=$O(HLP("EXCLUDE SUBSCRIBER",99999999),-1)
- ;XX Set the list of already excluded subscribers, so be sure we don't set it second time
- S AA=ADR_"("_RAEID_",I)"
- S I=0 F I=$O(HLP("EXCLUDE SUBSCRIBER",I)) Q:'I  S XX(HLP("EXCLUDE SUBSCRIBER",I))=""
- S I=0 F  S I=$O(@AA) Q:'I  S:'$D(XX(I)) J=J+1,HLP("EXCLUDE SUBSCRIBER",J)=I
+GETHLP(RAEID,HLP) ; Get excluded subcribers set into HLP array
+ N I,J,II S II=$O(HLP("EXCLUDE SUBSCRIBER",99999999),-1)+1
+ S I=0 F J=II:1 S I=$O(RASSSX(RAEID,I)) Q:'I  S HLP("EXCLUDE SUBSCRIBER",J)=I
  Q
 CHSUM ;CHECKSUM
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLTCPB.m	(revision 636)
@@ -1,18 +1,10 @@
 RAHLTCPB ; HIRMFO/REL,GJC,BNT,PAV - Rad/Nuc Med HL7 TCP/IP Bridge;05/21/99
- ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**12,17,25,51,71,81**;Mar 16, 1998;Build 12
  ; 07/05/2006 BAY/KAM Remedy Call 124379 Eliminate unneeded ORM msgs
- ; 09/01/2006   Acomodate multiple ORC/OBR segments Patch 81
- ; 
- ;Integration Agreements
- ;----------------------
- ;INIT^HLFNC2(2161); GENACK^HLMA1(2165); $$DT^XLFDT(10103)
- ; 
+ ; 09/01/2006   Acomodate multiplr ORC/OBR segments Patch 81
 EN1 ; Build the ^TMP("RARPT-REC" global when we receive the
  ; 07/05/2006 Remedy Call 124379 message from HL7. If RAHLTCPB is defined, do not broadcast ORM messages. As of the writing
- ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1 Generic provider: RADIOLOGY,OUTSIDE SERVICE
- N RATELE,RATELENM,RATELEPI,RATELEKN,RATELEDR,RATELEDF
- D TELE^RAHLRPTT ;Patch 84
- ;** branch to new HL7 logic when the HL7 version surpasses 2.3 **
- I HL("VER")>2.3,($T(^RAHLTCPX))'="" GOTO EN1^RAHLTCPX
+ ; of patch 71, RAHLTCPB is referenced in RAHLTCPB, UPSTAT^RAUTL0, & UP2^RAUTL1
+ ;G:$G(HL("VER"))]"2.3" EN1^RAHLTCPX
  S RASUB=HL("MID"),RAHLTCPB=1 K RAERR
  ;**********************************************
@@ -68,9 +60,7 @@
  . S:$P(RADTCN,$E(HL("ECH")),2)]"" ^TMP(RARRR,$J,RASUB,"RALONGCN")=$P(RADTCN,$E(HL("ECH")),2)
  . Q
- I $G(RADTI)'>0 S RAERR="Invalid exam registration timestamp" D XIT Q
- I $G(RACNI)'>0 S RAERR="Invalid exam record IEN" D XIT Q
  S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,25,HL("FS")) K RAHL70
  I RAHLD="" S RAERR="Missing Report Status" D XIT Q
- I "AFR"'[RAHLD S RAERR="Invalid Report Status: "_RAHLD D XIT Q
+ I "AFR"'[RAHLD S RAERR="Invalid Report Status" D XIT Q
  S ^TMP(RARRR,$J,RASUB,"RASTAT")=RAHLD
  G:$P(RARRR,"-",3) 112 S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,32,HL("FS")) K RAHL70
@@ -82,5 +72,5 @@
  E  D  ; $D(^VA(200,"B",RAVERF)) true, get the entry ien
  . S RAVERF=$O(^VA(200,"B",RAVERF,0))
- . S:'RAVERF RAERR="Invalid Provider Name: "_RAHLD
+ . S:'RAVERF RAERR="Invalid Provider Name"
  ; can't get resident info from medspeak
  S RAHLD=$$PCEXTR^RAHLO4(CNT,SEGMNT,33,HL("FS")),RARSDNT="" K RAHL70
@@ -96,5 +86,4 @@
  I $D(RAERR) D XIT Q
  D ESIG^RAHLO3
- ;
  ;If last OBR set provider info to all OBRs
  K XX F I=1:1:RACN S XX=RARRR_"-"_I D:$D(^TMP(XX,$J,RASUB))
@@ -110,5 +99,5 @@
  . Q:SEGMNT?@("1"""_HL("FS")_"""."""_HL("FS")_"""")  ;Quit if OBX is something as:    OBX||||||||
  . I $P(SEGMNT,HL("FS"),3)']"" S RAERR="Missing Observation Identifier" Q
- . S OBXTYP=$P($P(SEGMNT,HL("FS"),3),$E(HL("ECH"))),OBXTYP=$E($P(OBXTYP,"&",2))
+ . S OBXTYP=$P(SEGMNT,HL("FS"),3),OBXTYP=$E(OBXTYP,$F(OBXTYP,"&"))
  . S OBX2CE=""
  . S:OBXTYP="" OBXTYP=" "
@@ -144,10 +133,16 @@
  S X=$P(SEGMNT,HL("FS"),5)
  I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
- I $G(RATELE),$D(RATELEKN),X[RATELEKN S X=$P(X,RATELEKN,2),RATELENM=$P(X,"-"),RATELEPI=$TR($P(X,"-",2)," ","") ;SFVAMC/DAD/9-7-2007/Comment out the quit Q  ;Patch 84
  D PAR
  F J=0:0 S J=$O(^TMP("RARPT-HL7",$J,CNT,J)) Q:'J  S X1=^(J),X=$E(X1,1,125) D PAR I $L(X1)>125 S X=$E(X1,126,999) D PAR
  I X=""!(LIN'="") S L=999 D P2
  Q
- ;
+FORMAT ; Format report text for Escape Character delimited codes.
+ S Y=X N T,Q
+ I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X
+ I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X
+ I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X
+ I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X
+ I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
+ Q
 PAR ; Build text paragraph
  S LIN=LIN_X
@@ -167,5 +162,5 @@
  S MSA1="AA"
  Q:$E($G(HL("SAN")),1,3)'="RA-"  ; Don't allow non RA namespaced interfaces
- I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP"!$G(RATELE):"AE",1:"AR")
+ I $D(RAERR) S MSA1=$S($G(HL("SAN"))="RA-PSCRIBE-TCP":"AE",1:"AR")
  ; Added next line to support MedSpeak interface.  Must re-initialize
  ; FS and EC's before sending ACK.
@@ -176,12 +171,2 @@
  K HLRESLT D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT)
  Q
- ;
-FORMAT ; Format report text for Escape Character delimited codes.
- S Y=X N T,Q
- I Y["\S\" S Q=$F(Y,"\S\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"))_$E(Y,Q,$L(X)),Y=X
- I Y["\R\" S Q=$F(Y,"\R\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),2)_$E(Y,Q,$L(X)),Y=X
- I Y["\E\" S Q=$F(Y,"\E\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),3)_$E(Y,Q,$L(X)),Y=X
- I Y["\T\" S Q=$F(Y,"\T\"),T=Q-4,X=$E(Y,1,T)_$E(HL("ECH"),4)_$E(Y,Q,$L(X)),Y=X
- I X["\S\"!(X["\R\")!(X["\E\")!(X["\T\") D FORMAT
- Q
- ;
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAMAIN.m	(revision 636)
@@ -1,6 +1,5 @@
 RAMAIN ;HISC/FPT,GJC,CAH AISC/MJK,RMO;VMP/PW-Utility File Maintenance ;7/24/02  14:45
- ;;5.0;Radiology/Nuclear Medicine;**31,43,50,54,87**;Mar 16, 1998;Build 2
+ ;;5.0;Radiology/Nuclear Medicine;**31,43,50,54**;Mar 16, 1998
  ;
- ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Option File Access
 3 ;;Major AMIS Code Enter/Edit
  N RAI F RAI=1:1:5 W !?9,$P($T(REMIND+RAI),";;",2)
@@ -76,7 +75,5 @@
 10 ;;Procedure Modifiers Entry
  K DD,DO,DLAYGO,DIC,DA,DINUM,X,Y
- ;S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL"
- ; 11/15/07 BAY/KAM RA*5*87 Rem Call 205080 Changed next line to set DLAYGO equal to the file number instead of the file root
- S DIC="^RAMIS(71.2,",DLAYGO=71.2,DIC(0)="AEMQL"
+ S (DIC,DLAYGO)="^RAMIS(71.2,",DIC(0)="AEMQL"
  S DIC("A")="Select Procedure Modifier: ",DIC("W")="D PROHLP^RAMAIN"
  W ! D ^DIC K DIC,DLAYGO I +Y'>0 K D,X,Y,POP,I,DDH,DG,DISYS,DUOUT Q
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RO1.m	(revision 636)
@@ -1,4 +1,4 @@
 RAO7RO1 ;HISC/FPT-RAD/NM Error Messages ;8/28/97  14:16
- ;;5.0;Radiology/Nuclear Medicine;**2,75,86**;Mar 16, 1998;Build 7
+ ;;5.0;Radiology/Nuclear Medicine;**2,75**;Mar 16, 1998;Build 4
  ;
 EN1(RAERR) ; errors encountered with OE v3.0 back & frontdoor transmission
@@ -6,6 +6,4 @@
  I RAEMSG]"" Q RAEMSG
  Q "Error # "_RAERR_" does not exist"
- ;
- ;Note: Error code nine (9) disappears with the release of CPRS GUI V27. P86
  ;
 MSG ; error messages
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAO7RON.m	(revision 636)
@@ -1,10 +1,4 @@
 RAO7RON ;HISC/GJC- Request message from OE/RR. (frontdoor) ;2/2/98  12:34
- ;;5.0;Radiology/Nuclear Medicine;**41,75,86**;Mar 16, 1998;Build 7
- ;
- ;Supported IA #10040 reference to ^SC
- ;Supported IA #2187 reference to EN^ORERR
- ;Supported IA #10103 reference to ^XLFDT
- ;Supported IA #10141 reference to ^XPDUTL
- ;Supported IA #10106 reference to $$FMDATE^HLFNC
+ ;;5.0;Radiology/Nuclear Medicine;**41,75**;Mar 16, 1998;Build 4
  ;
  ;------------------------- Variable List -------------------------------
@@ -46,10 +40,6 @@
  S RAERR=$$EN3^RAO7VLD(44,+RAPV13) S:RAERR RAERR=3 Q:RAERR
  S RANEW(75.1,"+1,",22)=+RAPV13
- ;check the GUI version of CPRS at this facility:
- ;$$PATCH^XPDUTL("OR*3.0*243")=1 CPRS V27, else CPRS V26.
- I '$$PATCH^XPDUTL("OR*3.0*243") D  Q:RAERR  ;P86
- .I RAPV12="I",$P(^SC($P(RAPV13,U,1),0),U,3)'="W" S RAERR=9 Q
- .I RAPV12="O",$P(^SC($P(RAPV13,U,1),0),U,3)="W" S RAERR=9
- .Q
+ I RAPV12="I",$P(^SC($P(RAPV13,U,1),0),U,3)'="W" S RAERR=9 Q:RAERR
+ I RAPV12="O",$P(^SC($P(RAPV13,U,1),0),U,3)="W" S RAERR=9 Q:RAERR
  S RAPV119=$P(RADATA,RAHLFS,19)
  Q
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1.m	(revision 636)
@@ -1,17 +1,4 @@
-RAORD1 ;HISC/CAH - AISC/RMO-Request An Exam ; 06/27/07 07:22am
- ;;5.0;Radiology/Nuclear Medicine;**10,45,41,75,86**;Mar 16, 1998;Build 7
- ;
- ;Supported IA #10035 reference to ^DPT(
- ;Supported IA #10040 reference to ^SC(
- ;Supported IA #10060 reference to ^VA(200
- ;Supported IA #2055 reference to $$EXTERNAL^DILFD
- ;Supported IA #2378 reference to ORCHK^GMRAOR
- ;Supported IA #10061 reference to ^VADPT
- ;Supported IA #10112 reference to ^VASITE
- ;Supported IA #10103 reference to ^XLFDT
- ;Supported IA #10141 reference to ^XPDUTL
- ;Supported IA #10009 reference to FILE^DICN
- ;Supported IA #10018 reference to ^DIE
- ;
+RAORD1 ;HISC/CAH - AISC/RMO-Request An Exam ; 01/21/05 11:25am
+ ;;5.0;Radiology/Nuclear Medicine;**10,45,41,75**;Mar 16, 1998;Build 4
  ;*Billing Awareness Project:
  ; RABWDX Array: ICD Diagnosis^SC^AO^IR^EC^MST^HNC
@@ -21,29 +8,15 @@
  S RAPKG="" N RAPTLKUP,RAGMTS,RACOPYOR
  G ADDORD:$D(RAVSTFLG)&($D(RALIFN))&($D(RAPIFN))
- ;
  I '$D(RAREGFLG),'$D(RAVSTFLG) N RAPTLOCK K RAWARD D  G:'RAPTLKUP Q
 PAT .S DIC="^DPT(",DIC(0)="AEMQ" W ! D ^DIC K DIC
- .I Y<0 S RAPTLKUP=0 Q 
- .S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(") G:'RAPTLOCK PAT
+ .I Y<0 S RAPTLKUP=0 Q
+ .I $$ORVR^RAORDU()'<3 D  G:'RAPTLOCK PAT
+ ..S RAPTLOCK=$$LK^RAUTL19(+Y_";DPT(")
+ ..Q
  .S (DFN,RADFN)=+Y,(VA200,RAPTLKUP)=1
  .W ! D IN5^VADPT S:VAIP(1) RAWARD=$P(VAIP(5),"^",2)
  .D ELIG^RABWORD2
  .Q
- ;
-PL ;Ask for the patient location (REQ. LOCATION file: 75.1, field: #22)
- N RACPRS27 S RACPRS27=$$PATCH^XPDUTL("OR*3.0*243")
- S DIC("A")="Patient Location: ",DIC("B")=$S($D(RAWARD)#2:RAWARD,1:"")
- S DIC="^SC(",DIC(0)="AEMQ"
- ;
- ;With the installation of RA*5.0*86 and after the implementation of
- ;CPRS v27 all active locations are eligible for selection regardless
- ;of patient type.
- ;
- ;If RAWARD is defined it is set to the name of the ward; pass either a 0
- ;or 1.
- ;Pass either a 0 or 1 as a value for RACPRS27. If 1 then CPRS GUI v27
- ;(OR*3.0*243) is installed at this facility.
- S DIC("S")="I $$SCREEN^RAORD1A("_($D(RAWARD)#2)_","_(RACPRS27)_")"
- ;
+PL S DIC("A")="Patient Location: ",DIC("B")=$S($D(RAWARD):RAWARD,1:""),DIC="^SC(",DIC(0)="AEMQ",DIC("S")="I $$SCREEN^RAORD1A()"
  D ^DIC K DIC K:'$D(RAREGFLG) RAWARD G Q:Y<0 S RALIFN=+Y
  S DIC("A")="Person Requesting Order: "
@@ -66,10 +39,13 @@
  S RADIV=$S($D(^RA(79,RADIV,0)):RADIV,1:$O(^RA(79,0)))
  S RAMDV=$TR($G(^RA(79,+RADIV,.1)),"YyNn","1100")
- D:'$D(RACAT)#2  ;if not defined, define the variable RACAT
- .I $D(RAWARD)#2 S RACAT="INPATIENT" Q
- .N Y S Y=$G(^RADPT(RADFN,0)) I Y="" S RACAT="OUTPATIENT" Q
- .S RACAT=$$EXTERNAL^DILFD(70,.04,"",$P(Y,U,4))
- .S:RACAT="" RACAT="OUTPATIENT"
+ S RACAT=$S($D(RACAT):RACAT,$D(RAWARD):"INPATIENT",$P(RAL0,"^",2)="PERSONNEL HEALTH":"EMPLOYEE",'$D(^RADPT(RADFN,0)):"OUTPATIENT",$P(^(0),"^",4)]"":$P($P(^DD(70,.04,0),$P(^RADPT(RADFN,0),"^",4)_":",2),";"),1:"OUTPATIENT")
+ I "IO"[$E(RACAT,1) D
+ .S RASTRNG=$$MATCH^RAORD1A(RACAT,RALIFN)
+ .;if necessary, change category of exam to match type of requesting
+ .;location and display msg to user
+ .S RACAT=$P(RASTRNG,"^"),RAWARD=$P(RASTRNG,"^",2)
  .Q
+ K:$D(RAWARD)&($E(RACAT,1)="O") RAWARD
+ K RASTRNG
  ; clear clin hist if:
  ;   rad backdoor, or
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAORD1A.m	(revision 636)
@@ -1,80 +1,104 @@
-RAORD1A ;HISC/FPT-Request an Exam ;7/27/07  08:00
- ;;5.0;Radiology/Nuclear Medicine;**1,86**;Mar 16, 1998;Build 7
+RAORD1A ;HISC/FPT-Request an Exam ;9/29/97  10:40
+ ;;5.0;Radiology/Nuclear Medicine;**1**;Mar 16, 1998
  ;
- ;Call to WIN^DGPMDDCF (Supported IA #1246) from the SCREENW function
- ;Supported IA #10039 reference to ^DIC(42
- ;Supported IA #10040 reference to ^SC
- ;Supported IA #10061 reference to ^VADPT
- ;Supported IA #10103 reference to ^XLFDT
+CS ; Category of exam switch. Called from [RA ORDER EXAM] input template
+ ; when requesting an exam. User can change category of exam from
+ ; (1) inpatient to outpatient and select a clinic patient location OR
+ ; (2) outpatient to inpatient and select a ward patient location.
  ;
-SCREEN(RAINPAT,RACPRS27) ; screen for active clinics/wards
+ N RAA,RAB,X,Y K DIR
+ S RAA=$S($E(RACAT)="I":"INPATIENT",1:"OUTPATIENT")
+ S RAB=$S($E(RAA)="I":"OUTPATIENT",1:"INPATIENT")
+ W ! S DIR("A",1)="CATEGORY OF EXAM is currently "_RAA
+ S DIR("A",2)=" "
+ S DIR("A")="Want to change CATEGORY OF EXAM to "_RAB
+ S DIR(0)="Y"
+ D ^DIR K DIR
+ I $D(DIRUT) S RALIFN("OUT")="" Q
+ I Y=0 S RALIFN("NO")="" Q
+REQLOC ; select patient location
+ N DIC,RAHL,RAHLWD,RASCI W !
+ASK S DIC("A")="Patient Location: ",DIC="^SC(",DIC(0)="AEMQ"
+ I $E(RAB)="O" S DIC("S")="I $$TYPE^RAORD1A(RAB,+Y),$$SCREEN^RAORD1A" I '$D(RAOERRFG) S:$P($G(^SC(+RALIFN,0)),U,3)="C" DIC("B")=$P(^SC(+RALIFN,0),U,1)
+ I $E(RAB)="I" S DIC("S")="I $$TYPE^RAORD1A(RAB,+Y),$$SCREEN^RAORD1A" I '$D(RAOERRFG) S:$P($G(^SC(+RALIFN,0)),U,3)="W" DIC("B")=$P(^SC(+RALIFN,0),U,1)
+ D ^DIC K DIC
+ I +Y'>0 S RALIFN("OUT")="" Q
+ I $E(RAB)="I" S RAHLWD=+$G(^SC(+Y,42)) I RAHLWD S RAHL=+$G(^DIC(42,RAHLWD,44)) I RAHL,RAHL'=+Y W !!,*7,"This Hospital Location points to ",$P($G(^DIC(42,+Y,0)),U,1) G ASK
+ S RALIFN=+Y,RACAT=RAB
+ Q:$D(RAOERFLG)  ;quit if REQLOC was called from REQLOC1 
+ K:$E(RAB)="O" RAWARD
+ S:$E(RAB)="I" RAWARD=$P(^SC(+Y,0),U,1)
+ Q
+SCREEN() ; screen for active clinics/wards
  ; This code is also called from RAORD1 (screen for the Patient Location
- ; prompt which is a pointer to the HOSPITAL LOCATION (#44) file.)
- ; We want to EXCLUDE from our selection the following types of
- ; hospital locations:
+ ; prompt)
+ Q:$D(^SC(+Y,"OOS")) 0 ; don't want Occasion Of Service (OOS) locations
+ N RA44 S RA44=$G(^SC(+Y,0))
+ Q:"FI"[$P(RA44,"^",3) 0 ; File areas & Imaging Types are not selectable
+ I $P(RA44,"^",3)="W" G SCREENW ; ward check
+ ; check inactivation & reactivation dates of clinic/operating
+ ; room in file #44
+ I '$D(^SC(+Y,"I")) Q 1
+ ; This Hospital Location has an "I" node.  We have to check INACTIVATE
+ ; DATE & REACTIVATE DATE fields to determine if the Hosp. Location is
+ ; active.
+ N RASCA S RASCI=$G(^SC(+Y,"I")),RASCA=+$P(RASCI,"^",2)
+ ; RASCA is the REACTIVATE DATE
+ ; Not selectable if REACTIVATE DATE is beyond DT or null (0).
+ S RASCA=$S(RASCA=0:0,RASCA>DT:0,1:RASCA)
+ I +RASCI=0 Q 1 ; no INACTIVATE DATE
+ I +RASCI>DT Q 1 ; INACTIVATE DATE exceeds today's date
+ ; Check INACTIVATE DATE against REACTIVATE DATE
+ ; if REACTIVATE DATE exists and is not after (or is equal to) the
+ ; INACTIVATE DATE the location is not active.
+ I RASCA,(+RASCI<RASCA) Q 1
+ Q 0
+SCREENW ; check currently out-of-service field of ward file (#42)
+ N D0,DGPMOS,X
+ S D0=+$G(^SC(+Y,42)) I 'D0 Q 0
+ I '$D(^DIC(42,D0,0)) Q 0
+ S:$D(RAWHEN) DGPMOS=$P(RAWHEN,".",1)
+ D WIN^DGPMDDCF
+ S X=$S(X=0:1,1:0)
+ Q X
  ;
- ;  1) Occasion of Service (OOS) locations (fld: 50.01) 'OOS' node
- ;  2) File Area ("F") or Imaging ("I") locations (fld: 2)
- ;  3) Inactivate Date (fld: 2505) 'I' node
+REQLOC1 ; Requesting Location does not go with Category of Exam
+ ; Category of Exam = Inpatient  -> Requesting Location = Ward
+ ; Category of Exam = Outpatient -> Requesting Location = Clinic
+ ; Called from [RA OERR EDIT] and [RA QUICK EXAM ORDER] input templates
+ W !!?5,*7,"When the CATEGORY OF EXAM is "_$S(RAX="I":"Inpatient",1:"Outpatient")_" the REQUESTING LOCATION",!?5,"must be a "_$S(RAX="I":"Ward",1:"Clinic")_" or OR.",!
+ W !?5,"The current REQUESTING LOCATION is ",$S($P($G(^SC(+RALIFN,0)),U,1)]"":$P($G(^SC(+RALIFN,0)),U,1),1:"Unknown"),!
+ N RAB,X,Y
+ S RAX=$S(RAX="I":"INPATIENT",1:"OUTPATIENT"),RAB=RAX,RAOERRFG=""
+ D REQLOC
+ K RAOERRFG
+ Q
+TYPE(RACAT,Y) ; Indicates whether a Hospital Location is a valid selection.
+ ; If the patient is an inpatient, all operating room location types &
+ ; all wards are valid selections.  If the patient is an outpatient, all
+ ; operating room location types & all clinics are valid selections.
+ ; Input Variables: RACAT=$S(Inpatient:"I",1:"O") "O" for outpatient
+ ; Input Variables: Y=IEN of entries in the Hospital Location file
+ ; This fuction returns 1 if valid, 0 if not valid
+ N RAX S RAX=0
+ I $E(RACAT,1)="I" D
+ . I $P(^SC(+Y,0),U,3)="W"!($P(^SC(+Y,0),U,3)="OR") S RAX=1
+ . Q
+ E  D
+ . I $P(^SC(+Y,0),U,3)="C"!($P(^SC(+Y,0),U,3)="OR") S RAX=1
+ . Q
+ Q RAX
+MATCH(RACAT,RALOC) ; Detect mismatched req loc type and cat. of exam
+ ;                 and return code for correct category of exam
+ ; Input Variable: 'RACAT' - the value for the 'Category Of Exam' field.
+ ;                 Only passed in if either 'I' or 'O'.
+ ;                 'RALOC' - The ien of the 'Requesting Location'
+ ; Output: correct category (I or O)_"^"_$S(Category='I':ward,1:"")
  ;
- ; input: RAINPAT=1 if the patient is an inpatient located on a ward, else 0.
- ;        RACPRS27=1 if the environment is running CPRS GUI v27, else 0.
- ;
- Q:$D(^SC(+Y,"OOS"))#2 0 ; #1
- N RA44 S RA44=$G(^SC(+Y,0)),RA44(42)=$P($G(^SC(+Y,42)),U)
- Q:"^F^I^"[(U_$P(RA44,U,3)_U) 0 ; #2
- ;
- ; if the hospital location is defined as a ward set RAWARD to 1, else 0
- N RAWARD S RAWARD=0
- ;check the pointer to the WARD LOCATION file.
- I RA44(42)>0 D  Q:RAWARD=-1 0
- .;Error; the HOSPITAL LOCATION cannot be of TYPE 'Clinic' & point to a ward
- .I $P(RA44,U,3)="C" S RAWARD=-1 Q
- .;Error; bad pointers between files 42 & 44
- .I $P($G(^DIC(42,RA44(42),44)),U)'=+Y S RAWARD=-1 Q
- .;ok, set ward flag...
- .S RAWARD=1
- .Q
- ;
- ; 1) if the hospital location is a ward check if we should screen by ward
- ; 2) the hosp location=ward, facility is running v26, and we have an
- ;    outpatient quit zero (default of the $S)
- I RAWARD  Q $S(RACPRS27!RAINPAT:$$SCREENW(+Y),1:0)
- ;
- ; if the hospital location is a clinic, we have an inpatient, and the
- ; facility is not running CPRS v27 return 0
- I 'RACPRS27,(RAINPAT) Q 0
- ;
- ; Check INACTIVATE DATE against REACTIVATE DATE
- ; inactivate date = reactivate date (allow)
- ; inactivate date > reactivate date (disallow)
- ; inactivate date < reactivate date (allow)
- ;
- N RASCA,RASCI,RASCINDE S RASCINDE=$G(^SC(+Y,"I"))
- S RASCI=+$P(RASCINDE,U),RASCA=+$P(RASCINDE,U,2)
- ;
- Q $S(RASCI'>0:1,RASCI>DT:1,1:RASCI'>RASCA)
- ;
-SCREENW(Y) ; check the out-of-service field of the WARD LOCATION (#42) record.
- ;input Y: ien of the HOSPITAL LOCATION record
- ; RAWHEN: DATE DESIRED (Not guaranteed) (file: 75.1, fld: 21) optional
- ;output : '0' if not valid, else '1' if valid 
- N D0,DGPMOS,X
- S D0=+$G(^SC(Y,42))
- Q:'D0 0
- Q:'($D(^DIC(42,D0,0))#2) 0
- ;
- ;WIN^DGPMDDCF (Supported IA #1246) Is the ward active?
- ; Input
- ;  D0 "Dee zero" (req): IEN of WARD LOCATION file.  
- ;  DGPMOS (opt): defaults to DT. Is the ward in service on this date?  
- ; Output
- ;  X: 1 if out of service, 0 if in service, or -1 if input variables
- ;     not defined properly. Be careful; note the difference in their
- ;     boolean definition ('0'=success) and ours ('0'=failure)
- ;
- S:$D(RAWHEN)#2 DGPMOS=$P(RAWHEN,".",1)
- D WIN^DGPMDDCF
- Q 'X  ;alter 'X' (the WIN^DGPMDDCF output value) to meet our ($$SCREENW) output definition
+ N RA44 S RA44=$G(^SC(+RALOC,0))
+ I $E(RACAT,1)'="I",$E(RACAT,1)'="O" Q RACAT
+ I $E(RACAT,1)="O",$P(RA44,U,3)'="C",($P(RA44,U,3)'="OR") S RACAT="INPATIENT"
+ I $E(RACAT,1)="I",$P(RA44,U,3)'="W",($P(RA44,U,3)'="OR") S RACAT="OUTPATIENT"
+ Q RACAT_"^"_$S($E(RACAT,1)="I":$P(RA44,"^"),1:"")
  ;
 PREG(RADFN,RADT) ; Subroutine will display the pregnancy prompt to the
@@ -105,3 +129,2 @@
  F  S RACNT=$O(RAMOD(RACNT),-1) Q:RACNT=""!(X=0)  S:RAMOD(RACNT)=Y X=0
  Q X
- ;
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR.m	(revision 636)
@@ -1,4 +1,4 @@
 RARTR ;HISC/CAH COLUMBIA/REB AISC/MJK,RMO-Queue/print Reports ;11/27/98  09:05
- ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75,92**;Mar 16, 1998;Build 4
+ ;;5.0;Radiology/Nuclear Medicine;**5,13,16,27,43,55,75**;Mar 16, 1998;Build 4
 PRT ; Begin print/build of e-mail message
  ;
@@ -132,10 +132,5 @@
  K RARPT,RAHDFM,RAFTFM,RAV,RAIOF,RABTCH,RAOOUT,RAPIR,RAPIS,VAERR,Z
  ; K RASTRSK S RAFFLF=RAORIOF K RAORIOF,RAFFLF,RAERRFLG
- ; 05/15/08 BAY/KAM Patch RA*5*92 Added Conditional Kill to next line
- ; to support an AMIE interface (IA 708)
- K RASTRSK,RAORIOF,RAFFLF,RAERRFLG K:'($D(RAMIE)#2) DFN
- ;the next kill line corrects the CPRS V27 report display issue when repeated
- ;on same patient P92
- K %,DIW,DIWF,DIWI,DIWL,DIWT,DIWTC,DIWX,RAACNT,RADUPHX,RANUM,RAREZON,RAST
+ K RASTRSK,RAORIOF,RAFFLF,RAERRFLG
  Q
 Q ; Queue the report
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RARTR0.m	(revision 636)
@@ -1,23 +1,10 @@
 RARTR0 ;HISC/GJC-Queue/Print Radiology Rpts utility routine. ;1/8/97  08:07
- ;;5.0;Radiology/Nuclear Medicine;**8,26,74,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**8,26,74**;Mar 16, 1998;Build 2
  ; 06/28/2006 BAY/KAM Remedy Call 146291 - Change Patient Age to DOB
- ;
- ;Integration Agreements
- ;----------------------
- ;DT^DILF(2054); GETS^DIQ(2056); $$FMTE^XLFDT(10103); $$UP^XLFSTR(10104)
- ;NEW PERSON file read w/FM (10060)
- ;
-EN1 ; Called from RARTR ;P84 GETS^DIQ added... 
+EN1 ; Called from RARTR
  S RARPT(0)=$G(^RARPT(+$G(RARPT),0)) Q:RARPT(0)']""
  S RARPT(10)=$P(RARPT(0),"^",10)
  S RAVERF=+$P(RARPT(0),U,9),RAPVERF=+$P(RARPT(0),U,13)
- K RAPIR,RAPIS S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15)
- ;format of the RAPIR/RAPIS arrays: P84 logic
- ;RAPI*=IEN file 200
- ;RAPI*(200,RAPI*,.01)= NAME (required)
- ;RAPI*(200,RAPI*,20.2) = SIGNATURE BLOCK PRINTED NAME (if any)
- ;RAPI*(200,RAPI*,20.3) = SIGNATURE BLOCK TITLE (if any)
- I RAPIR D GETS^DIQ(200,RAPIR,".01;20.2;20.3","","RAPIR") S RAPIR("IENS")=RAPIR_","
- I RAPIS D GETS^DIQ(200,RAPIS,".01;20.2;20.3","","RAPIS") S RAPIS("IENS")=RAPIS_","
+ S RAPIR=+$P(RALB,"^",12),RAPIS=+$P(RALB,"^",15)
  S RAWHOVER=+$P(RARPT(0),"^",17)
  I RAVERF,((RAPIR=RAVERF)!(RAPIS=RAVERF)) D
@@ -25,17 +12,13 @@
  . Q
  I RAPIS D  Q:$D(RAOOUT)
- . ;get signature block name if defined
- . S RALBS=$E(RAPIS(200,RAPIS("IENS"),20.2),1,25)
- . S:RALBS="" RALBS=$E(RAPIS(200,RAPIS("IENS"),.01),1,25) ;default to NAME
- . ;
- . ;get signature block title if defined
- . S RALBST=$G(RAPIS(200,RAPIS("IENS"),20.3)) ; max: 50 chars
- . S:RALBST="" RALBST=$$TITLE^RARTR0(RAPIS)
- . ;
+ . S RALBS=$E($P($G(^VA(200,RAPIS,20)),"^",2),1,25)
+ . S:RALBS']"" RALBS=$E($P($G(VA(200,RAPIS,0)),"^"),1,25)
+ . S RALBST=$P($G(^VA(200,RAPIS,20)),"^",3) ; max: 50 chars
+ . I RALBST']"" S RALBST=$$TITLE^RARTR0(RAPIS)
  . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
  . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
  . I '$D(RAUTOE) D
- .. W !,"Primary Interpreting Staff:",!?2,$S(RALBS]"":RALBS,1:"Unknown")
- .. W:$L(RALBST) ", "_$E(RALBST,1,((IOM-$X)-16))
+ .. W !,"Primary Interpreting Staff:"
+ .. W !?2,$S(RALBS]"":RALBS,1:"Unknown"),", ",$E(RALBST,1,((IOM-$X)-16))
  .. ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING
  .. Q
@@ -43,8 +26,8 @@
  .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Staff:"
  .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="  "_$S(RALBS]"":RALBS,1:"Unknown")
- .. Q:'$L(RALBST)  N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
+ .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
  .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBST,1,((80-RALEN)-16))
  .. Q
- . I $D(RAVERFND)&(RAPIS=RAVERF),(RAPIS(200,RAPIS("IENS"),.01)'="RADIOLOGY,OUTSIDE SERVICE") D
+ . I $D(RAVERFND)&(RAPIS=RAVERF) D
  .. I $G(RARPT(10))']"",('$D(RAUTOE)) D  Q
  ... W:RAWHOVER=RAPIS !?10,"(Verifier, no e-sig)"
@@ -62,24 +45,18 @@
  . Q
  D SECSTF^RARTR1 Q:$D(RAOOUT)  ; Print secondary interp'ting staff now
- ;now for primary resident definitions...
  I RAPIR D  Q:$D(RAOOUT)
- . ;get signature block name if defined
- . S RALBR=$E(RAPIR(200,RAPIR("IENS"),20.2),1,25)
- . S:RALBR="" RALBR=$E(RAPIR(200,RAPIR("IENS"),.01),1,25) ;default to NAME
- . ;
- . ;get signature block title if defined
- . S RALBRT=$G(RAPIR(200,RAPIR("IENS"),20.3)) ; max: 50 chars
- . S:RALBRT="" RALBRT=$$TITLE^RARTR0(RAPIR)
- . ;
+ . S RALBR=$E($P($G(^VA(200,RAPIR,20)),"^",2),1,25)
+ . S:RALBR']"" RALBR=$E($P($G(VA(200,RAPIR,0)),"^"),1,25)
+ . S RALBRT=$P($G(^VA(200,RAPIR,20)),"^",3) ; max: 50 chars
+ . I RALBRT']"" S RALBRT=$$TITLE^RARTR0(RAPIR)
  . I '$D(RAUTOE) D:($Y+RAFOOT+4)>IOSL HANG^RARTR2 Q:$D(RAOOUT)
  . I '$D(RAUTOE) D HD^RARTR:($Y+RAFOOT+4)>IOSL
- . I '$D(RAUTOE) D
- .. W !,"Primary Interpreting Resident:",!?2,$S(RALBR]"":RALBR,1:"Unknown")
- .. W:$L(RALBRT) ", "_$E(RALBRT,1,((IOM-$X)-16))
- .. Q
+ . W:'$D(RAUTOE) !,"Primary Interpreting Resident:"
+ . W:'$D(RAUTOE) !?2,$S(RALBR]"":RALBR,1:"Unknown")_", ",$E(RALBRT,1,((IOM-$X)-16))
+ . ; The '-16' above is derived from $L("(Pre-Verifier)")+1 FORMATTING
  . I $D(RAUTOE) D
  .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="Primary Interpreting Resident:"
  .. S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))="  "_$S(RALBR]"":RALBR,1:"Unknown")
- .. Q:'$L(RALBRT)  N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
+ .. N RALEN S RALEN=$L(^TMP($J,"RA AUTOE",RAACNT))
  .. S ^TMP($J,"RA AUTOE",RAACNT)=^TMP($J,"RA AUTOE",RAACNT)_", "_$E(RALBRT,1,((80-RALEN)-16))
  .. Q
@@ -100,13 +77,14 @@
  . Q
  D SECRES^RARTR1 ; Print out secondary interp'ting resident now
- K RAPIR,RAPIS ;P84 kills added
  Q
- ;
-TITLE(X) ;Return the radiology classification in lieu of the signature block title
+TITLE(X) ; Determine an individuals title
  ; 'X' is the IEN of the Primary Interpreting Resident i.e, ^DD(70.03,12
  ; -OR-
  ; 'X' is the IEN of the Primary Interpreting Staff i.e, ^DD(70.03,15
- Q $S($D(^VA(200,"ARC","R",X)):"Resident Physician",$D(^VA(200,"ARC","S",X)):"Staff Physician",1:"")
- ; 
+ N Y
+ I $D(^VA(200,"ARC","R",X)) S Y="Resident Physician" Q Y
+ I $D(^VA(200,"ARC","S",X)) S Y="Staff Physician" Q Y
+ S Y=""
+ Q Y
 HEAD ; Set up header info for e-mail message (called from INIT^RARTR)
  ; 06/28/2006 BAY/KAM Remedy Call 146291 Change Patient Age to DOB
Index: FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m
===================================================================
--- FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAUTL1.m	(revision 636)
@@ -1,11 +1,6 @@
 RAUTL1 ;HISC/CAH,FPT,GJC AISC/MJK,RMO-Utility Routine ;10/22/97  13:54
- ;;5.0;Radiology/Nuclear Medicine;**5,9,18,71,82,81,84**;Mar 16, 1998;Build 13
+ ;;5.0;Radiology/Nuclear Medicine;**5,9,18,71,82**;Mar 16, 1998;Build 8
  ;last modification by SS for P18 June 19,00
  ;02/10/2006 BAY/KAM RA*5*71 Add ability to update exam data to V/R
- ;
- ;Integration Agreements
- ;----------------------
- ;DIC(10006); DIE(10018); FILE^DIE(2053); UPDATE^DIE(2053); EN^ORB3(1362); NOTE^ORX3(868)
- ;
  I "IOSCR"'[X!(X="") S X="Unknown" Q
  G @($E(X))
@@ -36,5 +31,5 @@
  ;Variable Y is returned as either an elapsed time in the form DD:HH:MM where DD=days, HH=hours, MM=minutes or as the string 'Neg. Time' indicating a negative elapsed time
  ;Variable Y1 is returned as the # of minutes of elapsed time
- I '$D(RAMTIME) S DIC="^DD(""FUNC"",",DIC(0)="FX",RAX=X,X="MINUTES" D ^DIC K DIC S X=RAX S:$D(^DD("FUNC",+Y,1)) RAMTIME=^(1) I '$D(RAMTIME) W $C(7),!!,"Can't continue --- No 'MINUTES' function found in File Manager" K Y,Y1 G Q
+ I '$D(RAMTIME) S DIC="^DD(""FUNC"",",DIC(0)="FX",RAX=X,X="MINUTES" D ^DIC K DIC S X=RAX S:$D(^DD("FUNC",+Y,1)) RAMTIME=^(1) I '$D(RAMTIME) W *7,!!,"Can't continue --- No 'MINUTES' function found in File Manager" K Y,Y1 G Q
  X RAMTIME S Y1=X I X<0 S Y="Neg. Time" G Q
 MINUTS S X(1)=X\1440,X=X-(1440*X(1)),X(2)=X\60,X(3)=X-(60*X(2)),Y=$E(100+X(1),2,3)_":"_$E(100+X(2),2,3)_":"_$E(100+X(3),2,3)
@@ -46,9 +41,9 @@
  I $G(RAIMGTY)="" K XQUIT Q  ; didn't sign-on to an imaging location
  D ^RACNLU G UPQ:"^"[X
- I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",DUZ)) W !!?3,$C(7),"You do not have the appropriate access privileges to act on completed exams." G UPDATE
- I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,$C(7),"Exam has been 'cancelled' therefore the status cannot be changed." G UPDATE
+ I $D(^RA(72,"AA",RAIMGTY,9,+RAST)),'$D(^XUSEC("RA MGR",DUZ)) W !!?3,*7,"You do not have the appropriate access privileges to act on completed exams." G UPDATE
+ I $D(^RA(72,"AA",RAIMGTY,0,+RAST)) W !!?3,*7,"Exam has been 'cancelled' therefore the status cannot be changed." G UPDATE
  ;D UP1 I RAOR>0 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI,DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"",",DR="100///""NOW""",DR(2,70.07)="2///U;3////"_$S($G(RADUZ):RADUZ,1:DUZ) D ^DIE
  D UP1 I RAOR>0 D
- .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):$G(DILOCKTM,3)
+ .L +^RADPT(RADFN,"DT",RADTI,"P",RACNI)
  .N RAIEN
  .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_","
@@ -56,11 +51,10 @@
  .K RAERR D UPDATE^DIE("E","RAFDA","RAIEN","RAERR")
  .K RAFDA,RAIENS
- .I $D(RAERR) S RAERR="Error in update of 70.07, .01 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) K RAIEN Q
+ .I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) K RAIEN Q
  .S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_","
  .S RAFDA(70.07,RAIENS,2)="U"
  .S RAFDA(70.07,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ)
- .D FILE^DIE(,"RAFDA","RAERR")
+ .D FILE^DIE(,"RAFDA")
  .L -^RADPT(RADFN,"DT",RADTI,"P",RACNI)
- .I $D(RAERR) S RAERR="Error in update of 70.07, 2,3 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR")
 UPQ K RAFDA,RAIENS
  K %,D,DA,DE,DIC,DIE,DQ,DR,I,J,POP,RACS,RAEND,RAF5,RAFL,RAFST,RAI,RAIX,RAJ1,RAORDIFN,RAPRIT,RAHEAD,RASN,RAOR,RASTI,RASSN,RADATE,RAST,RACN,RACNI,RADFN,RADTE,RADTI,RANME,RAPRC,RARPT,X,Y,Z,^TMP($J,"RAEX"),C,DIPGM Q
@@ -96,17 +90,15 @@
  ;S DR(2,70.05)=$S($P(RAMDV,"^",11)&('$D(ZTQUEUED)):".01;",1:"")_"2////"_RASTI_";3////"_$S($G(RADUZ):RADUZ,1:DUZ)
  ;D ^DIE
- L +^RADPT(RADFN,"DT",RADTI,"P",RACNI):$G(DILOCKTM,3)
+ L +^RADPT(RADFN,"DT",RADTI,"P",RACNI)
  N RAIEN
  S RAIENS=RACNI_","_RADTI_","_RADFN_","
  S RAFDA(70.03,RAIENS,3)=RASTI
  K RAERR D FILE^DIE(,"RAFDA","RAERR")
- I $D(RAERR) S RAERR="Error in update of 70.03 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR") L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) G UP2K ;L - P18
+ I $D(RAERR) L -^RADPT(RADFN,"DT",RADTI,"P",RACNI) G UP2K ;L - P18
  I $P(RAMDV,"^",10) D
- .N RAERR2
  .S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_","
  .S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT())
- .D UPDATE^DIE(,"RAFDA","RAIEN","RAERR")
+ .D UPDATE^DIE(,"RAFDA","RAIEN")
  .K RAFDA,RAIENS
- .I $D(RAERR) S RAERR="Error in update of 70.05, .01 "_$G(RAERR("DIERR",1,"TEXT",1)) K RAERR("DIERR")
  .Q:'$D(RAIEN(1))
  .I $P(RAMDV,"^",11),('$D(ZTQUEUED)) D
@@ -117,8 +109,7 @@
  .S RAFDA(70.05,RAIENS,2)=RASTI
  .S RAFDA(70.05,RAIENS,3)=$S($G(RADUZ):RADUZ,1:DUZ)
- .K RAERR2 D FILE^DIE(,"RAFDA","RAERR2")
- .I $D(RAERR2) S RAERR2="Error in update of 70.05 2,3 "_$G(RAERR2("DIERR",1,"TEXT",1)),RAERR=$S($D(RAERR):RAERR_";"_RAERR2,1:RAERR2)
+ .K RAERR2 D FILE^DIE(,"RAFDA")
  ;Patch RA*5*82 added next line send EXM message after status update, not before the update
- D:'$D(RAERR) EXM^RAHLRPC
+ D EXM^RAHLRPC
  L -^RADPT(RADFN,"DT",RADTI,"P",RACNI)
  ;
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTQ2.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTQ2.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTQ2.m	(revision 636)
@@ -1,5 +1,5 @@
 RTQ2 ;MJK,JSM/TROY ISC;Scheduling Link; ; 5/21/87  3:09 PM ;
- ;;2.0;Record Tracking;**13,15,21,45**;10/22/91;Build 7
-BLD I $D(SDPL) S RTINP=+$P(^RTV(195.9,RTB,0),"^",3)
+ ;;v 2.0;Record Tracking;**13,15,21**;10/22/91 
+BLD I SDPL S RTINP=+$P(^RTV(195.9,RTB,0),"^",3)
  E  S RTINP=0
  F RTBLD=0:0 S RTBLD=$O(^RTV(195.9,RTB,"RECS",RTBLD)) Q:'RTBLD  S X=$G(^(RTBLD,0)) I X]"" D
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB ; DRIVER FOR COMPILED XREFS FOR FILE #195.9 ; 10/15/04
+RTXB ; DRIVER FOR COMPILED XREFS FOR FILE #195.9 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB1.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB1.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB1.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB1 ; COMPILED XREF FOR FILE #195.9 ; 10/15/04
+RTXB1 ; COMPILED XREF FOR FILE #195.9 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB2.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB2.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB2.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB2 ; COMPILED XREF FOR FILE #195.9001 ; 10/15/04
+RTXB2 ; COMPILED XREF FOR FILE #195.9001 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB3.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB3.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB3.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB3 ; COMPILED XREF FOR FILE #195.9002 ; 10/15/04
+RTXB3 ; COMPILED XREF FOR FILE #195.9002 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB4.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB4.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB4.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB4 ; COMPILED XREF FOR FILE #195.9003 ; 10/15/04
+RTXB4 ; COMPILED XREF FOR FILE #195.9003 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB5.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB5.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB5.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB5 ; COMPILED XREF FOR FILE #195.9 ; 10/15/04
+RTXB5 ; COMPILED XREF FOR FILE #195.9 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB6.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB6.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB6.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB6 ; COMPILED XREF FOR FILE #195.9001 ; 10/15/04
+RTXB6 ; COMPILED XREF FOR FILE #195.9001 ; 01/30/05
  ; 
  S DA(1)=DA S DA=0
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB7.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB7.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB7.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB7 ; COMPILED XREF FOR FILE #195.9002 ; 10/15/04
+RTXB7 ; COMPILED XREF FOR FILE #195.9002 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB8.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXB8.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXB8.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXB8 ; COMPILED XREF FOR FILE #195.9003 ; 10/15/04
+RTXB8 ; COMPILED XREF FOR FILE #195.9003 ; 01/30/05
  ; 
  S DA=0
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXM.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXM.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXM.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXM ; DRIVER FOR COMPILED XREFS FOR FILE #190.3 ; 10/15/04
+RTXM ; DRIVER FOR COMPILED XREFS FOR FILE #190.3 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXM1.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXM1.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXM1.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXM1 ; COMPILED XREF FOR FILE #190.3 ; 10/15/04
+RTXM1 ; COMPILED XREF FOR FILE #190.3 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXM2.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXM2.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXM2.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXM2 ; COMPILED XREF FOR FILE #190.3 ; 10/15/04
+RTXM2 ; COMPILED XREF FOR FILE #190.3 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXP.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXP.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXP.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXP ; DRIVER FOR COMPILED XREFS FOR FILE #194.2 ; 10/15/04
+RTXP ; DRIVER FOR COMPILED XREFS FOR FILE #194.2 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXP1.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXP1.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXP1.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXP1 ; COMPILED XREF FOR FILE #194.2 ; 10/15/04
+RTXP1 ; COMPILED XREF FOR FILE #194.2 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXP2.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXP2.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXP2.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXP2 ; COMPILED XREF FOR FILE #194.2 ; 10/15/04
+RTXP2 ; COMPILED XREF FOR FILE #194.2 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXQ.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXQ.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXQ.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXQ ; DRIVER FOR COMPILED XREFS FOR FILE #190.1 ; 10/15/04
+RTXQ ; DRIVER FOR COMPILED XREFS FOR FILE #190.1 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXQ1.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXQ1.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXQ1.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXQ1 ; COMPILED XREF FOR FILE #190.1 ; 10/15/04
+RTXQ1 ; COMPILED XREF FOR FILE #190.1 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXQ2.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXQ2.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXQ2.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXQ2 ; COMPILED XREF FOR FILE #190.1 ; 10/15/04
+RTXQ2 ; COMPILED XREF FOR FILE #190.1 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXR.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXR.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXR.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXR ; DRIVER FOR COMPILED XREFS FOR FILE #190 ; 10/15/04
+RTXR ; DRIVER FOR COMPILED XREFS FOR FILE #190 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXR1.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXR1.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXR1.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXR1 ; COMPILED XREF FOR FILE #190 ; 10/15/04
+RTXR1 ; COMPILED XREF FOR FILE #190 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXR2.m
===================================================================
--- FOIAVistA/trunk/r/RECORD_TRACKING-RT/RTXR2.m	(revision 631)
+++ FOIAVistA/tag/r/RECORD_TRACKING-RT/RTXR2.m	(revision 636)
@@ -1,3 +1,3 @@
-RTXR2 ; COMPILED XREF FOR FILE #190 ; 10/15/04
+RTXR2 ; COMPILED XREF FOR FILE #190 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG10.m	(revision 636)
@@ -1,4 +1,20 @@
-DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 8/24/05 1:47pm
- ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658**;Aug 13, 1993
+DG10 ;ALB/MRL,DAK,AEG,PHH-LOAD/EDIT PATIENT DATA ; 1/5/2006  21:46
+ ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 START ;
  D LO^DGUTL
@@ -7,5 +23,13 @@
  . D EN^DGRPD
  . Q:$G(DGRPOUT)
- . D REG^IVMCQ($G(DFN))
+ . ;
+ . ; ** start of VOE change 1 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ . ;
+ . ; HEC query call only wanted/needed for VA agency code
+ . ;
+ . I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN))
+ . ;
+ . ; ** end of VOE change 1 **
+ . ;
  . D HINQ
  ;
@@ -17,5 +41,13 @@
  N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP
  K MPIFRTN
- D MPIQ^MPIFAPI(DFN)
+ ;
+ ; ** start of VOE change 2 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; MPI query call only wanted/needed for VA agency code
+ ;
+ I $G(DUZ("AG"))="V"!$$GET^XPAR("SYS","DG MPI") D MPIQ^MPIFAPI(DFN)
+ ;
+ ; ** end of VOE change 2 **
+ ;
  K MPIFRTN
  ;
@@ -27,5 +59,14 @@
 SKIP ;
  S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT G A
- D HINQ,REG^IVMCQ($G(DFN)) G A1
+ ;
+ ; ** start of VOE change 3 of 3: DAOU/WCJ,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; these query calls only wanted/needed for VA agency code
+ ;
+ I $G(DUZ("AG"))="V" D HINQ,REG^IVMCQ($G(DFN))
+ G A1
+ ;
+ ; ** end of VOE change 3 **
+ ;
  ;
 HINQ ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGCV.m	(revision 636)
@@ -1,7 +1,7 @@
-DGCV ;ALB/DW,ERC,BRM,TMK - COMBAT VET ELIGIBILTY; 10/15/05 ; 3/24/08 7:28am
- ;;5.3;Registration;**528,576,564,673,778**; Aug 13, 1993;Build 9
+DGCV ;ALB/DW,ERC,BRM,TMK - COMBAT VET ELIGIBILTY; 10/15/05
+ ;;5.3;Registration;**528,576,564,673**; Aug 13, 1993
  ;
 CVELIG(DFN) ;
- ;API will determine whether or not this veteran needs to have CV End
+ ;API will determine whether or not this vetearn needs to have CV End
  ;Date set.  If this determination cannot be done due to imprecise
  ;or missing dates, it returns which dates need editing.
@@ -10,12 +10,12 @@
  ;Output
  ;  RESULT
- ;    0 - CV End Date should not be set
- ;    1 - CV End Date should be set
+ ;    0 - CV End Date should not be updated
+ ;    1 - CV End Date should be updated
  ;  If critical dates are imprecise return the following
- ;    A - CV End Date should not be set, imprecise Service Sep date
- ;    B - CV End Date should not be set, imprecise Combat To date
- ;    C - CV End Date should not be set, imprecise Yugoslavia To date
- ;    D - CV End Date should not be set, imprecise Somalia To date
- ;    E - CV End Date should not be set, imprecise Pers Gulf To date
+ ;    A - CV End Date should not be updated, imprecise Service Sep date
+ ;    B - CV End Date should not be updated, imprecise Combat To date
+ ;    C - CV End Date should not be updated, imprecise Yugoslavia To date
+ ;    D - CV End Date should not be updated, imprecise Somalia To date
+ ;    E - CV End Date should not be updated, imprecise Pers Gulf To date
  ;  If the Service Sep Date is missing, and there are no OEF/OIF/UNKNOWN
  ;    OEF/OIF records on file, return the following so that it  will
@@ -84,57 +84,13 @@
  ;
 SETCV(DFN,DGSRV) ;calculate CV end date
- ;    DGSRV is the most recent of the Service Separation Date 
- ;    or the OEF/OIF To Date, called from file #2 new style 
- ;    cross reference "ACVCOM"
- N DGCVEDT,DGFDA,DGNDAA,DGPLUS3,DGTMPDT,DGYRS
- S DGNDAA=3080128
+ K DGCVEDT
+ N DGFDA
  I $G(DFN)']""!($G(DGSRV)']"") Q
  I '$D(^DPT(DFN)) Q
+ S DGCVEDT=$P($$SCH^XLFDT("24M",DGSRV),".")
+ I DGCVEDT=$G(DGCVDT) Q
  I $$GET1^DIQ(2,DFN_",",.5295,"I") Q
- D CVRULES(DFN,DGSRV,.DGYRS)
- Q:$G(DGYRS)'=3&($G(DGYRS)'=5)
- ;NDAA legislation, enacted 1/28/08, gives vets discharged
- ;on or after 1/28/03 (2 years previously) CV Eligibility 
- ;for 5 years.  Vets discharged before 1/28/03 get eligibility 
- ;for 3 years after enactment (or until 1/27/2011) DG*5.3*778
- S DGTMPDT=$S(DGYRS=3:DGNDAA,1:DGSRV)
- S DGCVEDT=($E(DGTMPDT,1,3)+DGYRS)_$E(DGTMPDT,4,7)
- S DGCVEDT=$$FMADD^XLFDT(DGCVEDT,-1)
  S DGFDA(2,DFN_",",.5295)=DGCVEDT
  D FILE^DIE(,"DGFDA")
- Q
- ;
-CVRULES(DFN,DGSRV,DGYRS) ;apply rules for the CV End Date
- ;extension project - DG*5.3*778
- ;DGSRV - most recent of Service Sep Date or OEIUUF to date
- ;   DGYRS = 3 years from NDAA or 1/27/2011
- ;         = 5 years from SSD or Enrollment App Date
- ;determine how many years extra CV eligibility to give
- N DGCIEN,DGCUTOFF,DGENRDT,DGPIEN,DGPRI,DGQT,DGSTAT
- ;determine if veteran has an enrollment record prior
- ;to 1/28/2008 (the NDAA date) and no CV End Date for
- ;this enrollment
- S DGYRS=5
- S (DGPRI,DGQT)=0
- S DGCUTOFF=3030128
- S DGCIEN=$$FINDCUR^DGENA(DFN)
- I $G(DGCIEN),($D(^DGEN(27.11,DGCIEN,0)))]"" D
- . S DGENRDT=$$GET1^DIQ(27.11,DGCIEN_",",75.01,"I") Q:$G(DGENRDT)']""
- . I $P(DGENRDT,".",1)<DGNDAA S DGPRI=1 Q
- . I DGENRDT'<DGNDAA D
- . . S DGPIEN=DGCIEN
- . . F  S DGPIEN=$$FINDPRI^DGENA(DGPIEN) Q:'DGPIEN  D  Q:DGQT
- . . . S DGENRDT=$$GET1^DIQ(27.11,DGPIEN_",",75.01,"I")
- . . . Q:$G(DGENRDT)']""
- . . . I $P(DGENRDT,".",1)<DGNDAA S (DGPRI,DGQT)=1
- ;if DGPRI=1, then there is an enrollment prior to 1/28/08
- I DGPRI=1 D  Q
- . I $G(DGCIEN)]"" S DGSTAT=$$GET1^DIQ(27.11,DGCIEN_",",.04,"E")
- . I $G(DGSTAT)["INITIAL APPLICATION BY VAMC"!($G(DGSTAT)["BELOW ENROLLMENT GROUP THRESHOLD") D
- . . I DGSRV<DGCUTOFF S DGYRS=3
- ;
- ;if no enrollment prior to 1/28/08 (DGPRI=0) check service date
- ;against cutoff date - 1/28/03
- I DGSRV<DGCUTOFF S DGYRS=3
  Q
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGDEATH.m	(revision 636)
@@ -1,4 +1,4 @@
 DGDEATH ;ALB/MRL/PJR-PROCESS DECEASED PATIENTS ; 10/27/04 9:45pm
- ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725,772**;Aug 13, 1993;Build 4
+ ;;5.3;Registration;**45,84,101,149,392,545,595,568,563,725**;Aug 13, 1993;Build 12
  ;
 GET N DGMTI,DATA
@@ -14,5 +14,5 @@
  I $P(DGDNEW,"^",1)="",$P(DGDNEW,"^",2)'="" S DR=".352////@" D ^DIE
  I $P(DGDNEW,"^",1)="" K ^TMP("DEATH",$J) G GET
-SN I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE I $P($G(^DPT(DFN,.35)),"^",3)']"" D SNDISP G SN
+ I $P(DGDNEW,"^",1)'="" S DR=".353" D ^DIE
  I DGDOLD'=DGDNEW D DISCHRGE
  I $P(DGDOLD,"^",1)'=$P(DGDNEW,"^",1) D XFR
@@ -143,15 +143,2 @@
  I YES,'((TYPE=27)!(TYPE=32)) S DGDONOT=1
  Q
-SNDISP ; Source of Notification display choices
- N DIR,DTOUT,DUOUT,DIRUT,DIROUT,DGLIST,DGLNAME,I,X,Y
- S DGLIST=$P($G(^DD(2,.353,0)),"^",3)
- S Y=6
- S DIR("?",1)=" "
- S DIR("?",2)=" This is a required response. Please select from the following:"
- S DIR("?",3)=" Entering '^' will take you back to the Source of Notification prompt"
- S DIR("?",4)=" "
- S DIR("?",5)=" "
- F X=1:1 S DGLNAME=$P(DGLIST,";",X) Q:DGLNAME']""  S DIR("?",Y)="      "_$P(DGLNAME,":",1)_"      "_$P(DGLNAME,":",2) S Y=Y+1
- S DIR("?",Y)=" "
- F I=1:1 Q:'$D(DIR("?",I))  W !,DIR("?",I)
- Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMSTAPI.m	(revision 636)
@@ -1,4 +1,23 @@
-DGMSTAPI ;ALB/SCK - API's for Military Sexual Trauma ; 2/28/02 4:56pm
- ;;5.3;Registration;**195,243,308,353,379,443,700**;Aug 13, 1993
+DGMSTAPI ;ALB/SCK - API's for Military Sexual Trauma ;7:34 PM  30 Jan 2008
+ ;;5.3;Registration;**195,243,308,353,379,443,700,VWEHR1**;WorldVistA 30-Jan-08
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ ;
  Q
  ;
@@ -43,5 +62,11 @@
  . S DGMST="0^U"
  S DGIEN=""
- S DGIEN=+$P($Q(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1),",",5)
+ ;
+ ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ ;
+ ;S DGIEN=+$P($Q(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN),-1),",",5)
+ S DGIEN=+$P($$Q^VWUTIL($NA(^DGMS(29.11,"APDT",DFN,DGDATE,DGIEN)),-1),",",5)
+ ;
+ ;END CHANGE
  ;
  ; Check for valid ien, if entry missing, return Unknown
@@ -130,7 +155,7 @@
 NEWQ Q $G(DGRSLT)
  ;
-DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.  
+DELMST(MSTIEN) ; Deletes the MST HISTORY File (#29.11) entry passed in.
  ; This call is not to be used except from inside the DG MST List
- ; Manager interface.  
+ ; Manager interface.
  ;
  ; Input
@@ -199,5 +224,5 @@
  ;
 DATE(DFN,DGDT) ;Determine 'current' MST date
- ; 
+ ;
  ;  Input
  ;    DFN  - Patient's DFN
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTCOU1.m	(revision 636)
@@ -1,4 +1,20 @@
-DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ; 8/13/04 8:31am
- ;;5.3;Registration;**33,45,54,335,358,401,436,445,564**;Aug 13, 1993
+DGMTCOU1 ;ALB/REW,LD,JAN,AEG,LBD - COPAY UTILITIES ;11/5/06  20:29
+ ;;5.3;Registration;**33,45,54,335,358,401,436,445,564,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 AUTO(DFN,AUTOEX) ;
  ; Returns 1 if Exempt from CP w/o needing MT/CP information
@@ -69,4 +85,8 @@
 THRESHQT Q
 DISPMAS(DFN) ; Displays Co
+ ;New EHR code    ;DAOU/JLG 2/4/05
+ ;not relevant to Agency EHR
+ Q:$G(DUZ("AG"))="E"
+ ;End EHR modifications
  N DGCPS,DGEX,Y,AUTOEX
  S DGEX=$$AUTO(DFN,.AUTOEX)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXD ; GENERATED FROM 'DGMT ENTER/EDIT DEPENDENTS' INPUT TEMPLATE(#468), FILE 408.22;08/13/05
+DGMTXD ; GENERATED FROM 'DGMT ENTER/EDIT DEPENDENTS' INPUT TEMPLATE(#468), FILE 408.22;12/18/05
  D DE G BEGIN
 DE S DIE="^DGMT(408.22,",DIC=DIE,DP=408.22,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGMT(408.22,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXD1 ; ;08/13/05
+DGMTXD1 ; ;12/18/05
  S X=DE(25),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X X ^DD(408.22,.11,1,1,79.2) S X=X="" I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(408.22,.11,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD2.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXD2 ; ;08/13/05
+DGMTXD2 ; ;12/18/05
  S X=DG(DQ),DIC=DIE
  X ^DD(408.22,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGMT(408.22,D0,0)):^(0),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(408.22,.11,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD3.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXD3 ; ;08/13/05
+DGMTXD3 ; ;12/18/05
  S X=DE(27),DIC=DIE
  I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)="",$P(^(0),U,11) D INC^DGMTDD2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXD4.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXD4 ; ;08/13/05
+DGMTXD4 ; ;12/18/05
  S X=DG(DQ),DIC=DIE
  I $D(^DGMT(408.22,DA,0)),$P(^(0),U,12)=0,$P(^(0),U,11) D INC^DGMTDD2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXE.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXE.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXE.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXE ; GENERATED FROM 'DGMT ENTER/EDIT EXPENSES' INPUT TEMPLATE(#474), FILE 408.21;08/13/05
+DGMTXE ; GENERATED FROM 'DGMT ENTER/EDIT EXPENSES' INPUT TEMPLATE(#474), FILE 408.21;12/18/05
  D DE G BEGIN
 DE S DIE="^DGMT(408.21,",DIC=DIE,DP=408.21,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGMT(408.21,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 11/22/06
+DGMTXX1 ; DRIVER FOR COMPILED XREFS FOR FILE #408.21 ; 11/06/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX11.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX11.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX11.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 11/22/06
+DGMTXX11 ; COMPILED XREF FOR FILE #408.21 ; 11/06/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX12.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX12.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX12.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 11/22/06
+DGMTXX12 ; COMPILED XREF FOR FILE #408.21 ; 11/06/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX2.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 11/22/06
+DGMTXX2 ; DRIVER FOR COMPILED XREFS FOR FILE #408.22 ; 11/06/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX21.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX21.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX21.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 11/22/06
+DGMTXX21 ; COMPILED XREF FOR FILE #408.22 ; 11/06/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX22.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX22.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX22.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 11/22/06
+DGMTXX22 ; COMPILED XREF FOR FILE #408.22 ; 11/06/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX3.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 11/22/06
+DGMTXX3 ; DRIVER FOR COMPILED XREFS FOR FILE #408.31 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX31.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX31.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX31.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 11/22/06
+DGMTXX31 ; COMPILED XREF FOR FILE #408.31 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX32.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX32.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTXX32.m	(revision 636)
@@ -1,3 +1,3 @@
-DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 11/22/06
+DGMTXX32 ; COMPILED XREF FOR FILE #408.31 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m	(revision 636)
@@ -1,8 +1,26 @@
-DGPFUT ;ALB/RPM - PRF UTILITIES ; 6/7/05 3:13pm
- ;;5.3;Registration;**425,554,650**;Aug 13, 1993;Build 3
+DGPFUT ;ALB/RPM - PRF UTILITIES ;7:46 PM  30 Jan 2008
+ ;;5.3;Registration;**425,554,650,VWEHR1**;WorldVistA 30-Jan-08
+ ;
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
  Q   ;no direct entry
  ;
-ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS)   ;wrap FileMan Classic Reader call
+ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
  ;
  ;  Input
@@ -175,5 +193,5 @@
  ;This function verifies that a given patient has a valid national
  ;Integration Control Number.
- ; 
+ ;
  ;  Supported DBIA #2701:  The supported DBIA is used to access MPI
  ;                         APIs to retrieve ICN and determine if ICN
@@ -207,5 +225,5 @@
  ;TREATED value immediately prior to the date for the treating facility
  ;passed as the second parameter.  The most recent treating facility
- ;will be returned when the second parameter is missing, null, or zero. 
+ ;will be returned when the second parameter is missing, null, or zero.
  ;
  ;  Input:
@@ -237,9 +255,30 @@
  . ;find entry for previous treating facility
  . S DGNAM="DGDARR"
- . S DGARR=$QUERY(@DGNAM@(""),-1)
+ . ;
+ . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ . ;
+ . ;S DGARR=$QUERY(@DGNAM@(""),-1)
+ . S DGARR=$$Q^VWUTIL($NA(@DGNAM@("")),-1)
+ . ;
+ . ;END CHANGE
+ . ;
  . I DGLTF,DGARR]"" D
  . . I $QS(DGARR,2)'=DGLTF D
- . . . F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
- . . S DGARR=$QUERY(@DGARR,-1)
+ . . . ;
+ . . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ . . . ;
+ . . . ;F  S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
+ . . . F  S DGARR=$$Q^VWUTIL($NA(@DGARR),-1) Q:+$QS(DGARR,2)=DGLTF
+ . . . ;
+ . . . ;END CHANGE
+ . . . ;
+ . . ;
+ . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
+ . . ;
+ . . ;S DGARR=$QUERY(@DGARR,-1)
+ . . S DGARR=$$Q^VWUTIL($NA(@DGARR),-1)
+ . . ;
+ . . ;END CHANGE
+ . . ;
  ;
  Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX6.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX6.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX6.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX6 ; GENERATED FROM 'DGPM SPECIALTY TRANSFER' INPUT TEMPLATE(#451), FILE 405;11/22/06
+DGPMX6 ; GENERATED FROM 'DGPM SPECIALTY TRANSFER' INPUT TEMPLATE(#451), FILE 405;11/06/06
  D DE G BEGIN
 DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX61.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX61.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX61.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX61 ; ;11/22/06
+DGPMX61 ; ;11/06/06
  S X=DE(14),DIC=DIE
  S DGPMDDF=9 D ^DGPMDD2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX62.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX62.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX62.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX62 ; ;11/22/06
+DGPMX62 ; ;11/06/06
  S X=DG(DQ),DIC=DIE
  S DGPMDDF=9 D ^DGPMDD1
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX63.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX63.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX63.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX63 ; ;11/22/06
+DGPMX63 ; ;11/06/06
  S X=DE(16),DIC=DIE
  S DGPMDDF=8,DGPMDDT=0 D ^DGPMDDCN
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX64.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX64.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX64.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX64 ; ;11/22/06
+DGPMX64 ; ;11/06/06
  S X=DG(DQ),DIC=DIE
  S DGPMDDF=8,DGPMDDT=1 D ^DGPMDDCN
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX65.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX65.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX65.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX65 ; ;11/22/06
+DGPMX65 ; ;11/06/06
  S X=DE(17),DIC=DIE
  S DGPMDDF=19,DGPMDDT=0 D ^DGPMDDCN
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX66.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX66.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX66.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX66 ; ;11/22/06
+DGPMX66 ; ;11/06/06
  S X=DG(DQ),DIC=DIE
  S DGPMDDF=19,DGPMDDT=1 D ^DGPMDDCN
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX67.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX67.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMX67.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMX67 ; ;11/22/06
+DGPMX67 ; ;11/06/06
  D DE G BEGIN
 DE S DIE="^DGPM(",DIC=DIE,DP=405,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPM(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMXX ; DRIVER FOR COMPILED XREFS FOR FILE #405 ; 11/22/06
+DGPMXX ; DRIVER FOR COMPILED XREFS FOR FILE #405 ; 11/06/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 11/22/06
+DGPMXX1 ; COMPILED XREF FOR FILE #405 ; 11/06/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMXX2.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPMXX2 ; COMPILED XREF FOR FILE #405 ; 11/22/06
+DGPMXX2 ; COMPILED XREF FOR FILE #405 ; 11/06/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTF4.m	(revision 636)
@@ -1,4 +1,4 @@
 DGPTF4 ;ALB/JDS - PTF ENTRY/EDIT-4 ; 2/19/04 9:33am
- ;;5.3;Registration;**114,115,397,510,517,478,683,775**;Aug 13, 1993;Build 3
+ ;;5.3;Registration;**114,115,397,510,517,478,683**;Aug 13, 1993
  ;
 WR ;
@@ -59,7 +59,5 @@
  ;change made to allow release of 470, before grouper released to vamc's
  ;  patch 115
- ;DGDAT = effective date of DRG used in DGPTICD (468=CMS-DRG,998=MS-DRG)
- I DRG=469,(+$G(DGDAT)<3071001)  W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
- I DRG=998 W !!,*7,"Unable to release DRG ",DRG,".  Please verify data entered.",*7 D HANG^DGPTUTL G EN1
+ I DRG=469 W !!,*7,"Unable to release DRG ",DRG,". Please verify data entered.",*7 D HANG^DGPTUTL G EN1
  I $D(DGCST),'DGCST D CEN G EN1:'DGCST
  I '$P(^DGPT(PTF,0),"^",4) W !,"Updating TRANSFER DRGs..." S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFDEL.m	(revision 636)
@@ -1,4 +1,4 @@
-DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 7/31/07 11:19am
- ;;5.3;Registration;**517,760**;Aug 13, 1993;Build 11
+DGPTFDEL ;ALB/JDS - PTF ENTRY DELETION ; 1/15/04 8:23am
+ ;;5.3;Registration;**517**;Aug 13, 1993
  ;
 A D LO^DGUTL I $D(^DISV(DUZ,"^DPT(")),$D(^("^DGPT(")) S A=+^("^DGPT("),B=+^("^DPT(") I $D(^DGPT(A,0)),$D(^DPT(B,0)) S:(+^DGPT(A,0)'=B&$D(^DGPT("B",B))) ^DISV(DUZ,"^DGPT(")=""
@@ -52,5 +52,6 @@
  ;
 KDGPT ; -- kill DGPT rec ; input DGPTIFN := ifn
- S DA=DGPTIFN,DIK="^DGPT(",FLAG=1,I=0 F  S I=$O(^DGCPT(46,"C",DA,I)) Q:'I  I '$G(^DGCPT(46,I,9)) S FLAG=0 Q
+ S DA=DGPTIFN,DIK="^DGPT(",FLAG=1,I=0 F  S I=$O(^DGCPT(46,"C",DA,I)) Q:'I  I '$G(^DGCPT(I,9)) S FLAG=0 Q
+ I FLAG S I=0 F  S I=$O(^DGICD9(46.1,"C",DA,I)) Q:'I  I '$G(^DGICD9(I,9)) S FLAG=0 Q
  I 'FLAG W !,"CANNOT DELETE THE PTF RECORD WHEN THERE ARE ACTIVE ORDERS OR CPT RECORDS." H 2 K FLAG Q
  D ^DIK K DA,DIK,I,FLAG
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM4.m	(revision 636)
@@ -1,4 +1,4 @@
-DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 12/18/07 11:37am
- ;;5.3;Registration;**114,195,397,510,565,775**;Aug 13, 1993;Build 3
+DGPTFM4 ;ALB/MTC/ADL - PTF ENTRY/EDIT-2 ; 11/19/03 11:37am
+ ;;5.3;Registration;**114,195,397,510,565**;Aug 13, 1993
  ;;ADL;Update for CSV Project;;Mar 26, 2003
  ;
@@ -26,8 +26,5 @@
  . W $S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,4)_" ("_$P(DGPTTMP,U,2)_")",1:"**********-"_L),!?17
  D PRN2^DGPTFM8:DG300]""
- I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=998!(DRG=999)!((DRG=468!(DRG=469)!(DRG=470))&(+$P($G(M1),U,10)<3071001)) *7 W !!?14,"TRANSFER DRG: ",DRG D
- . N DXD,DGDX
- . S DXD=$$DRGD^ICDGTDRG(DRG,"DGDX",,$P(M1,U,10)),DGDS=0
- . F  S DGDS=$O(DGDX(DGDS)) Q:'+DGDS  Q:DGDX(DGDS)=" "  W !,DGDX(DGDS)
+ I $P(M1,U,20) S DRG=$P(M1,U,20) W:DRG=468!(DRG=469)!(DRG=470) *7 W !!?14,"TRANSFER DRG: ",DRG F DGDRGNM=0:0 S DGDRGNM=$O(^ICD(DRG,1,DGDRGNM)) Q:'DGDRGNM  W !,$P(^(DGDRGNM,0),U,1)
 JUMP K DG300 F I=$Y:1:21 W !
 X S DGNUM=$S($D(M(DGZM0+1)):501_"-"_(DGZM0+1),1:"MAS") G 501^DGPTFJC:DGST
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTICD.m	(revision 636)
@@ -1,4 +1,4 @@
 DGPTICD ;ALB/MTC - PTF DRG Grouper Utility ; 2/19/02 3:08pm
- ;;5.3;Registration;**375,441,510,559,599,606,775**;Aug 13, 1993;Build 3
+ ;;5.3;Registration;**375,441,510,559,599,606**;Aug 13, 1993
  ;variables to pass in:
  ;  DGDX <- format: DX CODE1^DX CODE2^DX CODE3^...                      (REQUIRED)
@@ -49,6 +49,5 @@
  ;
 PRT ;print DRG and national HCFA values
- I (ICDDATE<3071001)&(DRG=468!(DRG=469)!(DRG=470)) W *7
- I DRG=998!(DRG=999) W *7
+ I DRG=468!(DRG=469)!(DRG=470) W *7
  S Y=ICDDATE D DD^%DT ; Y=external representation of effective date
  W !!?9,"Effective Date:","  ",Y
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTR1.m	(revision 636)
@@ -1,4 +1,4 @@
 DGPTR1 ;ALB/MTC - PTF VERIFICATION ; 12/14/06 10:31am
- ;;5.3;Registration;**58,247,338,342,423,415,565,678,696,729,781**;Aug 13, 1993;Build 1
+ ;;5.3;Registration;**58,247,338,342,423,415,565,678,696,729**;Aug 13, 1993;Build 59
 START S T=$E(Y,2,3),T=$S(T=40&($E(Y,28)="P"):"P40",1:T),ERR=$P($T(@("T"_T)),";;",2,999),W=$P($T(@(T)),";;",2,999),F=31 D L
  I T=70 S ERR=$P($T(T701),";;",2,999),W=$P($T(701),";;",2,999),F=72 D L
@@ -26,7 +26,7 @@
 T60 ;;1:DATE OF PROCEDURE^2:LOSING BD SEC^3:DIALYSIS TYPE^4:NUMBER OF TREATMENTS^5:PROCEDURE CODE
  ;
-LOGIC ;;X'?.N^X'?.A&(X'=" ")^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X'?.A)&(X'?.N)&(X'=" ")^(X'?.AN)&('$P(DG0,U,4))^((T1)&(X'=" "))!(('T1)&(X'?.AN)&('$P(DG0,U,4)))^(X'?.AN)
+LOGIC ;;X'?.N^X'?.A&(X'=" ")^X'=" "^X'?.N&(X'=" ")^X'?.A&(X'=" ")^0^X'?.N&(X'="X")^X'=" "&(X'="P")^X="E"^X="Y"^X=" "^X'="A"&(X'=" ")^(X'?.A)&(X'?.N)&(X'=" ")^(X'?.AN)&('$P(DG0,U,4))^((T1)&(X'=" "))!(('T1)&(X'?.AN)&('$P(DG0,U,4)))
  ;
- ; ; edit check# ; edit field ; # x check preformed ; display error name #
+ ; edit check# ; edit field ; # x check preformed ; display error name #
 10 ;;6;;12;1^2;1;1;1^5;1;1;1^1;2;1;2^2;2;1;2^4;3;3;3^6;;3;3^4;4;1;4^6;5;1;5^2;6;1;6^2;7;1;7^1;8;8;8^6;;1;9^11;9;1;9^4;10;1;10^4;10;1;11^1;11;5;12^7;11;5;12^2;12;1;13^6;;1;13^1;;6;14^2;;1;15^1;;1;16^4;;6;17^3;;1;18^5;;1;19^3;;29
  ;
@@ -35,5 +35,5 @@
 701 ;;15;;2;1^1;;3;2^4;;1;3^4;;1;4^12;;1;5^4;;3;5^4;;1;6^4;;4;7^4;;1;8^5;;3;9^5;;1;10^5;;1;11^13;12;2;12^13;13;12;13^5;;1;14^3;;17
  ;
-50 ;;1;1;10;1^1;;6;2^16;3;2;3^1;4;3;4^1;5;3;5^6;;1;6^11;7;3;7^6;;32;7^6;;9;8^14;;6;9^14;;2;10^6;;1;11^4;;1;16^4;;1;17^12;;1;18^4;;3;18^4;;1;19^4;;4;20^4;;1;21^5;;3;22^5;;1;23^5;;1;24
+50 ;;1;1;10;1^1;;6;2^13;3;2;3^1;4;3;4^1;5;3;5^6;;1;6^11;7;3;7^6;;32;7^6;;9;8^14;;6;9^14;;2;10^6;;1;11^4;;1;16^4;;1;17^12;;1;18^4;;3;18^4;;1;19^4;;4;20^4;;1;21^5;;3;22^5;;1;23^5;;1;24
  ;
 53 ;;1;;10;1^1;;6;2^13;;2;3^1;;6;4^13;;2;5^1;;3;6^1;;3;7^3;;9;8^3;;54;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX1 ; GENERATED FROM 'DG101' INPUT TEMPLATE(#426), FILE 45;09/04/07
+DGPTX1 ; GENERATED FROM 'DG101' INPUT TEMPLATE(#426), FILE 45;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX11.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX11.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX11.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX11 ; ;09/04/07
+DGPTX11 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX110.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX110.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX110.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX110 ; ;01/12/06
+DGPTX110 ; ;04/03/06
  S X=DE(12),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX111.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX111.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX111.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX111 ; ;01/12/06
+DGPTX111 ; ;04/03/06
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX112.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX112.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX112.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX112 ; ;01/12/06
+DGPTX112 ; ;04/03/06
  S X=DE(13),DIC=DIE
  D KILL^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX113.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX113.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX113.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX113 ; ;01/12/06
+DGPTX113 ; ;04/03/06
  S X=DG(DQ),DIC=DIE
  D SET^DGREGDD1(DA,.116,.11,6,$E(X,1,5))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX114.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX114.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX114.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX114 ; ;01/12/06
+DGPTX114 ; ;04/03/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX12.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX12.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX12.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX12 ; ;09/04/07
+DGPTX12 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX13.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX13.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX13.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX13 ; ;09/04/07
+DGPTX13 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,.06,",DIC=DIE,DP=2.06,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.06,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX14.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX14.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX14.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX14 ; ;09/04/07
+DGPTX14 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,.02,",DIC=DIE,DP=2.02,DL=3,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.02,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX15.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX15.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX15.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX15 ; ;09/04/07
+DGPTX15 ; ;12/27/07
  S X=DE(14),DIC=DIE
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX16.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX16.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX16.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX16 ; ;09/04/07
+DGPTX16 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.32103,1,1,1.3) I X S X=DIV S Y(2)=";"_$S($D(^DD(2,.3212,0)):$P(^(0),U,3),1:""),Y(1)=$S($D(^DPT(D0,.321)):^(.321),1:"") S X=$P($P(Y(2),";"_$P(Y(1),U,12)_":",2),";",1) S DIU=X K Y S X=DIV S X="" X ^DD(2,.32103,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX17.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX17.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX17.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX17 ; ;09/04/07
+DGPTX17 ; ;12/27/07
  S X=DE(16),DIC=DIE
  D AUTOUPD^DGENA2(DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX18.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX18.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX18.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX18 ; ;09/04/07
+DGPTX18 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  D AUTOUPD^DGENA2(DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX19.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX19.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX19.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX19 ; ;09/04/07
+DGPTX19 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=2,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -80,5 +80,5 @@
  S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
-C1F1 N X,X1,X2 S DIXR=627 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
+C1F1 N X,X1,X2 S DIXR=646 D C1X1(U) K X2 M X2=X D C1X1("O") K X1 M X1=X
  D
  . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX4.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX4 ; GENERATED FROM 'DG401' INPUT TEMPLATE(#428), FILE 45;12/12/07
+DGPTX4 ; GENERATED FROM 'DG401' INPUT TEMPLATE(#428), FILE 45;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX41.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX41.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX41.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX41 ; ;12/12/07
+DGPTX41 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""S"",",DIC=DIE,DP=45.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"S",DA,""))=""
@@ -69,5 +69,5 @@
 C5S S X="" G:DG(DQ)=X C5F1 K DB
 C5F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=422,423,424,425,426 S DIEZRXR(45.01,DIXR)=""
+ F DIXR=437,438,439,440,441 S DIEZRXR(45.01,DIXR)=""
  Q
 X5 S %DT="ETX" D ^%DT S X=+Y K:Y<1 X I $D(X) X $S(X<$P(^DGPT(DA(1),0),U,2):"W !,""Not before admission"" K X",X>($S($D(^(70)):$S(+^(70):+^(70),1:9999999),1:9999999)):"W !,""Not after discharge"" K X",1:"")
@@ -115,5 +115,5 @@
  S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
 C15F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=422 S DIEZRXR(45.01,DIXR)=""
+ F DIXR=437 S DIEZRXR(45.01,DIXR)=""
  Q
 X15 S DIC("S")="S DGI=8,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -141,5 +141,5 @@
  S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
 C20F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=423 S DIEZRXR(45.01,DIXR)=""
+ F DIXR=438 S DIEZRXR(45.01,DIXR)=""
  Q
 X20 S DIC("S")="S DGI=9,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -165,5 +165,5 @@
  D ^DGPTX43
 C25F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=424 S DIEZRXR(45.01,DIXR)=""
+ F DIXR=439 S DIEZRXR(45.01,DIXR)=""
  Q
 X25 S DIC("S")="S DGI=10,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX42.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX42.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX42.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX42 ; ;12/12/07
+DGPTX42 ; ;12/27/07
  S X=DE(25),DIC=DIE
  K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX43.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX43.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX43.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX43 ; ;12/12/07
+DGPTX43 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX44.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX44.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX44.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX44 ; ;12/12/07
+DGPTX44 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""S"",",DIC=DIE,DP=45.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"S",DA,""))=""
@@ -62,5 +62,5 @@
  S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
 C1F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=425 S DIEZRXR(45.01,DIXR)=""
+ F DIXR=440 S DIEZRXR(45.01,DIXR)=""
  Q
 X1 S DIC("S")="S DGI=11,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -88,5 +88,5 @@
  S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
 C6F1 S DIEZRXR(45.01,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=426 S DIEZRXR(45.01,DIXR)=""
+ F DIXR=441 S DIEZRXR(45.01,DIXR)=""
  Q
 X6 S DIC("S")="S DGI=12,DGCR=""AO"",DGSB=""S"" D EN1^DGPTFJC K DGI,DGCR,DGSB,K I 'DGER" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX45.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX45.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX45.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTX45 ; ;12/12/07
+DGPTX45 ; ;12/27/07
  ;;
-1 N X,X1,X2 S DIXR=422 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=437 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",1)
@@ -12,5 +12,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=423 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=438 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",2)
@@ -23,5 +23,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=424 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=439 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",3)
@@ -34,5 +34,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=425 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=440 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",4)
@@ -45,5 +45,5 @@
  S X=$G(X(1))
  Q
-5 N X,X1,X2 S DIXR=426 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
+5 N X,X1,X2 S DIXR=441 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",5)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX5.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX5.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX5.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX5 ; GENERATED FROM 'DG501' INPUT TEMPLATE(#430), FILE 45;09/05/07
+DGPTX5 ; GENERATED FROM 'DG501' INPUT TEMPLATE(#430), FILE 45;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX51.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX51.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX51.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX51 ; ;09/05/07
+DGPTX51 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
@@ -128,5 +128,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C22F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=447 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=462 S DIEZRXR(45.02,DIXR)=""
  Q
 X22 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=5 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -158,5 +158,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C27F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=448 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=463 S DIEZRXR(45.02,DIXR)=""
  Q
 X27 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=6 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX52.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX52.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX52.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX52 ; ;09/05/07
+DGPTX52 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
@@ -66,5 +66,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C1F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=449 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=464 S DIEZRXR(45.02,DIXR)=""
  Q
 X1 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -96,5 +96,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C6F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=450 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=465 S DIEZRXR(45.02,DIXR)=""
  Q
 X6 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -126,5 +126,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C11F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=451 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=466 S DIEZRXR(45.02,DIXR)=""
  Q
 X11 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX53.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX53.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX53.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX53 ; ;09/05/07
+DGPTX53 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX54.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX54.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX54.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX54 ; ;09/05/07
+DGPTX54 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX55.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX55.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX55.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTX55 ; ;09/05/07
+DGPTX55 ; ;12/27/07
  ;;
-1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=462 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
@@ -12,5 +12,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=463 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
@@ -23,5 +23,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=464 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
@@ -34,5 +34,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=465 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
@@ -45,5 +45,5 @@
  S X=$G(X(1))
  Q
-5 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
+5 N X,X1,X2 S DIXR=466 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX7.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX7.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX7.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX7 ; GENERATED FROM 'DG701' INPUT TEMPLATE(#432), FILE 45;02/13/06
+DGPTX7 ; GENERATED FROM 'DG701' INPUT TEMPLATE(#432), FILE 45;04/03/06
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
@@ -73,5 +73,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C4F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=432 S DIEZRXR(45,DIXR)=""
+ F DIXR=447 S DIEZRXR(45,DIXR)=""
  Q
 X4 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=1 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -101,5 +101,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C11F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=434 S DIEZRXR(45,DIXR)=""
+ F DIXR=449 S DIEZRXR(45,DIXR)=""
  Q
 X11 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=2 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -128,5 +128,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C17F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=435 S DIEZRXR(45,DIXR)=""
+ F DIXR=450 S DIEZRXR(45,DIXR)=""
  Q
 X17 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=3 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -153,5 +153,5 @@
  D ^DGPTX72
 C23F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=436 S DIEZRXR(45,DIXR)=""
+ F DIXR=451 S DIEZRXR(45,DIXR)=""
  Q
 X23 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=4 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX71.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX71.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX71.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX71 ; ;02/13/06
+DGPTX71 ; ;04/03/06
  S X=DE(23),DIC=DIE
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX72.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX72.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX72.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX72 ; ;02/13/06
+DGPTX72 ; ;04/03/06
  S X=DG(DQ),DIC=DIE
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX73.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX73.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX73.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX73 ; ;02/13/06
+DGPTX73 ; ;04/03/06
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
@@ -61,5 +61,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=437 S DIEZRXR(45,DIXR)=""
+ F DIXR=452 S DIEZRXR(45,DIXR)=""
  Q
 X1 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=5 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -89,5 +89,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C8F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=438 S DIEZRXR(45,DIXR)=""
+ F DIXR=453 S DIEZRXR(45,DIXR)=""
  Q
 X8 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=6 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -116,5 +116,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C14F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=439 S DIEZRXR(45,DIXR)=""
+ F DIXR=454 S DIEZRXR(45,DIXR)=""
  Q
 X14 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=7 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -143,5 +143,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C20F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=440 S DIEZRXR(45,DIXR)=""
+ F DIXR=455 S DIEZRXR(45,DIXR)=""
  Q
 X20 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=8 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX74.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX74.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX74.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX74 ; ;02/13/06
+DGPTX74 ; ;04/03/06
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
@@ -62,5 +62,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=441 S DIEZRXR(45,DIXR)=""
+ F DIXR=456 S DIEZRXR(45,DIXR)=""
  Q
 X1 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=9 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -88,5 +88,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C6F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=442 S DIEZRXR(45,DIXR)=""
+ F DIXR=457 S DIEZRXR(45,DIXR)=""
  Q
 X6 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=10 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -114,5 +114,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C11F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=443 S DIEZRXR(45,DIXR)=""
+ F DIXR=458 S DIEZRXR(45,DIXR)=""
  Q
 X11 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=11 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -140,5 +140,5 @@
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
 C16F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=444 S DIEZRXR(45,DIXR)=""
+ F DIXR=459 S DIEZRXR(45,DIXR)=""
  Q
 X16 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=12 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -164,5 +164,5 @@
  D ^DGPTX76
 C21F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=445 S DIEZRXR(45,DIXR)=""
+ F DIXR=460 S DIEZRXR(45,DIXR)=""
  Q
 X21 D ICDEN^DGPTF5 Q:X=""  S DIC("S")="S DGI=13 D EN3^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX75.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX75.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX75.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX75 ; ;02/13/06
+DGPTX75 ; ;04/03/06
  S X=DE(21),DIC=DIE
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX76.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX76.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX76.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX76 ; ;02/13/06
+DGPTX76 ; ;04/03/06
  S X=DG(DQ),DIC=DIE
  X "N DG1 S DG1=$P(^DGPT(DA,0),""^"",1) N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  D:(+DG1>0) ADGRU^DGRUDD01(DG1)"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX77.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX77.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX77.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX77 ; ;02/13/06
+DGPTX77 ; ;04/03/06
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX78.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX78.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX78.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTX78 ; ;02/13/06
+DGPTX78 ; ;04/03/06
  ;;
-1 N X,X1,X2 S DIXR=432 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
@@ -15,5 +15,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=434 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=449 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
@@ -29,5 +29,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=435 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=450 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
@@ -43,5 +43,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=436 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=451 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
@@ -57,5 +57,5 @@
  S X=$G(X(1))
  Q
-5 N X,X1,X2 S DIXR=437 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
+5 N X,X1,X2 S DIXR=452 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
@@ -71,5 +71,5 @@
  S X=$G(X(1))
  Q
-6 N X,X1,X2 S DIXR=438 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
+6 N X,X1,X2 S DIXR=453 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
@@ -85,5 +85,5 @@
  S X=$G(X(1))
  Q
-7 N X,X1,X2 S DIXR=439 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
+7 N X,X1,X2 S DIXR=454 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
@@ -99,5 +99,5 @@
  S X=$G(X(1))
  Q
-8 N X,X1,X2 S DIXR=440 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
+8 N X,X1,X2 S DIXR=455 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
@@ -113,5 +113,5 @@
  S X=$G(X(1))
  Q
-9 N X,X1,X2 S DIXR=441 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
+9 N X,X1,X2 S DIXR=456 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX79.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX79.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX79.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTX79 ; ;02/13/06
+DGPTX79 ; ;04/03/06
  ;;
-1 N X,X1,X2 S DIXR=442 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=457 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
@@ -15,5 +15,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=443 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=458 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
@@ -29,5 +29,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=444 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=459 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11")
@@ -43,5 +43,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=445 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=460 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX8.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX8.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX8.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX8 ; GENERATED FROM 'DG801' INPUT TEMPLATE(#1664), FILE 46.1;09/05/07
+DGPTX8 ; GENERATED FROM 'DG801' INPUT TEMPLATE(#1664), FILE 46.1;12/27/07
  D DE G BEGIN
 DE S DIE="^DGICD9(46.1,",DIC=DIE,DP=46.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGICD9(46.1,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX81.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX81.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTX81.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTX81 ; ;09/05/07
+DGPTX81 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGICD9(46.1,",DIC=DIE,DP=46.1,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGICD9(46.1,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXC ; GENERATED FROM 'DG PTF CREATE PTF ENTRY' INPUT TEMPLATE(#443), FILE 45;12/28/04
+DGPTXC ; GENERATED FROM 'DG PTF CREATE PTF ENTRY' INPUT TEMPLATE(#443), FILE 45;04/07/05
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
@@ -78,5 +78,5 @@
  I $P(^DGPT(DA,0),U,4),$P(^(0),U) S ^DGPT("AFEE",$P(^DGPT(DA,0),U),$E(X,1,30),DA)=""
 C1F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=432,433,434,435,436,437,438,439,440,441,442,443,444,445,446 S DIEZRXR(45,DIXR)=""
+ F DIXR=447,448,449,450,451,452,453,454,455,456,457,458,459,460,461 S DIEZRXR(45,DIXR)=""
  Q
 X1 Q
@@ -133,5 +133,5 @@
 C5S S X="" G:DG(DQ)=X C5F1 K DB
 C5F1 S DIEZRXR(45,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=432,433,434,435,436,437,438,439,440,441,442,443,444,445,446 S DIEZRXR(45,DIXR)=""
+ F DIXR=447,448,449,450,451,452,453,454,455,456,457,458,459,460,461 S DIEZRXR(45,DIXR)=""
  Q
 X5 Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXC1 ; ;12/28/04
+DGPTXC1 ; ;04/07/05
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC2.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTXC2 ; ;12/28/04
+DGPTXC2 ; ;04/07/05
  ;;
-1 N X,X1,X2 S DIXR=432 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
@@ -15,5 +15,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=433 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"PDX")
@@ -29,5 +29,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=434 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
@@ -43,5 +43,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=435 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
@@ -57,5 +57,5 @@
  S X=$G(X(1))
  Q
-5 N X,X1,X2 S DIXR=436 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
+5 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
@@ -71,5 +71,5 @@
  S X=$G(X(1))
  Q
-6 N X,X1,X2 S DIXR=437 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
+6 N X,X1,X2 S DIXR=452 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
@@ -85,5 +85,5 @@
  S X=$G(X(1))
  Q
-7 N X,X1,X2 S DIXR=438 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
+7 N X,X1,X2 S DIXR=453 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
@@ -99,5 +99,5 @@
  S X=$G(X(1))
  Q
-8 N X,X1,X2 S DIXR=439 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
+8 N X,X1,X2 S DIXR=454 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
@@ -113,5 +113,5 @@
  S X=$G(X(1))
  Q
-9 N X,X1,X2 S DIXR=440 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
+9 N X,X1,X2 S DIXR=455 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXC3.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTXC3 ; ;12/28/04
+DGPTXC3 ; ;04/07/05
  ;;
-1 N X,X1,X2 S DIXR=441 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=456 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
@@ -15,5 +15,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=442 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=457 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
@@ -29,5 +29,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=443 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=458 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
@@ -43,5 +43,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=444 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=459 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11")
@@ -57,5 +57,5 @@
  S X=$G(X(1))
  Q
-5 N X,X1,X2 S DIXR=445 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
+5 N X,X1,X2 S DIXR=460 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
@@ -71,5 +71,5 @@
  S X=$G(X(1))
  Q
-6 N X,X1,X2 S DIXR=446 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
+6 N X,X1,X2 S DIXR=461 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD13")
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX ; DRIVER FOR COMPILED XREFS FOR FILE #45 ; 12/12/07
+DGPTXX ; DRIVER FOR COMPILED XREFS FOR FILE #45 ; 12/27/07
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX1 ; COMPILED XREF FOR FILE #45 ; 12/12/07
+DGPTXX1 ; COMPILED XREF FOR FILE #45 ; 12/27/07
  ; 
  S DIKZK=2
@@ -98,5 +98,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^DGPT("B",$E(X,1,30),DA)
-CR1 S DIXR=432
+CR1 S DIXR=447
  K X
  S X(1)=$P(DIKZ(0),U,1)
@@ -111,5 +111,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
-CR2 S DIXR=433
+CR2 S DIXR=448
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -125,5 +125,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"PDX")
-CR3 S DIXR=434
+CR3 S DIXR=449
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -139,5 +139,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
-CR4 S DIXR=435
+CR4 S DIXR=450
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -153,5 +153,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
-CR5 S DIXR=436
+CR5 S DIXR=451
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -167,5 +167,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
-CR6 S DIXR=437
+CR6 S DIXR=452
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -181,5 +181,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
-CR7 S DIXR=438
+CR7 S DIXR=453
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -195,5 +195,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
-CR8 S DIXR=439
+CR8 S DIXR=454
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -209,5 +209,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
-CR9 S DIXR=440
+CR9 S DIXR=455
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -223,5 +223,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
-CR10 S DIXR=441
+CR10 S DIXR=456
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -237,5 +237,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
-CR11 S DIXR=442
+CR11 S DIXR=457
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -251,5 +251,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
-CR12 S DIXR=443
+CR12 S DIXR=458
  K X
 END G ^DGPTXX2
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX10.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX10.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX10.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX10 ; COMPILED XREF FOR FILE #45.01 ; 12/12/07
+DGPTXX10 ; COMPILED XREF FOR FILE #45.01 ; 12/27/07
  ; 
  S DA(1)=DA S DA=0
@@ -18,5 +18,5 @@
  S X=$P(DIKZ(0),U,12)
  I X'="" S ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)=""
-CR1 S DIXR=422
+CR1 S DIXR=437
  K X
  S X(1)=$P(DIKZ(0),U,1)
@@ -26,5 +26,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"S",1)
-CR2 S DIXR=423
+CR2 S DIXR=438
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
@@ -35,5 +35,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"S",2)
-CR3 S DIXR=424
+CR3 S DIXR=439
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
@@ -44,5 +44,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"S",3)
-CR4 S DIXR=425
+CR4 S DIXR=440
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
@@ -53,5 +53,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"S",4)
-CR5 S DIXR=426
+CR5 S DIXR=441
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX11.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX11.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX11.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX11 ; COMPILED XREF FOR FILE #45.02 ; 12/12/07
+DGPTXX11 ; COMPILED XREF FOR FILE #45.02 ; 12/27/07
  ; 
  S DA=0
@@ -64,5 +64,5 @@
  S X=$P(DIKZ(0),U,15)
  I X'="" X ^DD(45.02,15,1,992,1)
-CR1 S DIXR=447
+CR1 S DIXR=462
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -73,5 +73,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
-CR2 S DIXR=448
+CR2 S DIXR=463
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -82,5 +82,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
-CR3 S DIXR=449
+CR3 S DIXR=464
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -91,5 +91,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
-CR4 S DIXR=450
+CR4 S DIXR=465
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -100,5 +100,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
-CR5 S DIXR=451
+CR5 S DIXR=466
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -109,5 +109,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
-CR6 S DIXR=452
+CR6 S DIXR=467
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -118,5 +118,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD6")
-CR7 S DIXR=453
+CR7 S DIXR=468
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -127,5 +127,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD7")
-CR8 S DIXR=454
+CR8 S DIXR=469
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -136,5 +136,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD8")
-CR9 S DIXR=455
+CR9 S DIXR=470
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -145,5 +145,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9M^DGPTDDCR(.X,.DA,"M ICD9")
-CR10 S DIXR=456
+CR10 S DIXR=471
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX12.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX12.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX12.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX12 ; COMPILED XREF FOR FILE #45.05 ; 12/12/07
+DGPTXX12 ; COMPILED XREF FOR FILE #45.05 ; 12/27/07
  ; 
  S DA=0
@@ -18,5 +18,5 @@
  S X=$P(DIKZ(0),U,9)
  I X'="" S ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)=""
-CR1 S DIXR=427
+CR1 S DIXR=442
  K X
  S X(1)=$P(DIKZ(0),U,1)
@@ -26,5 +26,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"P",1)
-CR2 S DIXR=428
+CR2 S DIXR=443
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
@@ -35,5 +35,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"P",2)
-CR3 S DIXR=429
+CR3 S DIXR=444
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
@@ -44,5 +44,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"P",3)
-CR4 S DIXR=430
+CR4 S DIXR=445
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
@@ -53,5 +53,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT0^DGPTDDCR(.X,.DA,"P",4)
-CR5 S DIXR=431
+CR5 S DIXR=446
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX13.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX13.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX13.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX13 ; COMPILED XREF FOR FILE #45.0535 ; 12/12/07
+DGPTXX13 ; COMPILED XREF FOR FILE #45.0535 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX14.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX14.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX14.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX14 ; COMPILED XREF FOR FILE #45.06 ; 12/12/07
+DGPTXX14 ; COMPILED XREF FOR FILE #45.06 ; 12/27/07
  ; 
  S DA=0
@@ -12,5 +12,5 @@
  S X=$P(DIKZ(0),U,6)
  I X'="" D ADD^AUPNVSIT
-CR1 S DIXR=624
+CR1 S DIXR=200
  K X
  S X(1)=$P(DIKZ(0),U,1)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX2.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX2 ; COMPILED XREF FOR FILE #45 ; 12/12/07
+DGPTXX2 ; COMPILED XREF FOR FILE #45 ; 12/27/07
  ; 
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -14,5 +14,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
-CR13 S DIXR=444
+CR13 S DIXR=459
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -29,5 +29,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD11")
-CR14 S DIXR=445
+CR14 S DIXR=460
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -44,5 +44,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4),X2(5))=""
  . D KDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
-CR15 S DIXR=446
+CR15 S DIXR=461
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX3.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX3 ; COMPILED XREF FOR FILE #45.01 ; 12/12/07
+DGPTXX3 ; COMPILED XREF FOR FILE #45.01 ; 12/27/07
  ; 
  S DA(1)=DA S DA=0
@@ -18,5 +18,5 @@
  S X=$P(DIKZ(0),U,12)
  I X'="" K ^DGPT(DA(1),"S","AO",$E(X,1,30),DA)
-CR1 S DIXR=422
+CR1 S DIXR=437
  K X
  S X(1)=$P(DIKZ(0),U,1)
@@ -27,5 +27,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",1)
-CR2 S DIXR=423
+CR2 S DIXR=438
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
@@ -37,5 +37,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",2)
-CR3 S DIXR=424
+CR3 S DIXR=439
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
@@ -47,5 +47,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",3)
-CR4 S DIXR=425
+CR4 S DIXR=440
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
@@ -57,5 +57,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"S",4)
-CR5 S DIXR=426
+CR5 S DIXR=441
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"S",DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX4.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX4 ; COMPILED XREF FOR FILE #45.02 ; 12/12/07
+DGPTXX4 ; COMPILED XREF FOR FILE #45.02 ; 12/27/07
  ; 
  S DA=0
@@ -64,5 +64,5 @@
  S X=$P(DIKZ(0),U,15)
  I X'="" X ^DD(45.02,15,1,992,2)
-CR1 S DIXR=447
+CR1 S DIXR=462
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -74,5 +74,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
-CR2 S DIXR=448
+CR2 S DIXR=463
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -84,5 +84,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
-CR3 S DIXR=449
+CR3 S DIXR=464
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -94,5 +94,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
-CR4 S DIXR=450
+CR4 S DIXR=465
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -104,5 +104,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
-CR5 S DIXR=451
+CR5 S DIXR=466
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -114,5 +114,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
-CR6 S DIXR=452
+CR6 S DIXR=467
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -124,5 +124,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD6")
-CR7 S DIXR=453
+CR7 S DIXR=468
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -134,5 +134,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD7")
-CR8 S DIXR=454
+CR8 S DIXR=469
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -144,5 +144,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD8")
-CR9 S DIXR=455
+CR9 S DIXR=470
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
@@ -154,5 +154,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD9")
-CR10 S DIXR=456
+CR10 S DIXR=471
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"M",DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX5.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX5.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX5.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX5 ; COMPILED XREF FOR FILE #45.05 ; 12/12/07
+DGPTXX5 ; COMPILED XREF FOR FILE #45.05 ; 12/27/07
  ; 
  S DA=0
@@ -18,5 +18,5 @@
  S X=$P(DIKZ(0),U,9)
  I X'="" K ^DGPT(DA(1),"P","AP6",$E(X,1,30),DA)
-CR1 S DIXR=427
+CR1 S DIXR=442
  K X
  S X(1)=$P(DIKZ(0),U,1)
@@ -27,5 +27,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"P",1)
-CR2 S DIXR=428
+CR2 S DIXR=443
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
@@ -37,5 +37,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"P",2)
-CR3 S DIXR=429
+CR3 S DIXR=444
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
@@ -47,5 +47,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"P",3)
-CR4 S DIXR=430
+CR4 S DIXR=445
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
@@ -57,5 +57,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2))=""
  . D KDGPT0^DGPTDDCR(.X,.DA,"P",4)
-CR5 S DIXR=431
+CR5 S DIXR=446
  K X
  S DIKZ(0)=$G(^DGPT(DA(1),"P",DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX6.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX6.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX6.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX6 ; COMPILED XREF FOR FILE #45.0535 ; 12/12/07
+DGPTXX6 ; COMPILED XREF FOR FILE #45.0535 ; 12/27/07
  ; 
  S DA=0
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX7.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX7.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX7.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX7 ; COMPILED XREF FOR FILE #45.06 ; 12/12/07
+DGPTXX7 ; COMPILED XREF FOR FILE #45.06 ; 12/27/07
  ; 
  S DA=0
@@ -12,5 +12,5 @@
  S X=$P(DIKZ(0),U,1)
  I X'="" K ^DGPT(DA(1),"C","B",$E(X,1,30),DA)
-CR1 S DIXR=624
+CR1 S DIXR=200
  K X
  S X(1)=$P(DIKZ(0),U,1)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX8.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX8.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX8.m	(revision 636)
@@ -1,3 +1,3 @@
-DGPTXX8 ; COMPILED XREF FOR FILE #45 ; 12/12/07
+DGPTXX8 ; COMPILED XREF FOR FILE #45 ; 12/27/07
  ; 
  S DIKZK=1
@@ -92,5 +92,5 @@
  S X=$P(DIKZ(70),U,11)
  I X'="" X ^DD(45,80,1,992,1)
-CR1 S DIXR=432
+CR1 S DIXR=447
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -105,5 +105,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"DXLS")
-CR2 S DIXR=433
+CR2 S DIXR=448
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -118,5 +118,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"PDX")
-CR3 S DIXR=434
+CR3 S DIXR=449
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -131,5 +131,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD1")
-CR4 S DIXR=435
+CR4 S DIXR=450
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -144,5 +144,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD2")
-CR5 S DIXR=436
+CR5 S DIXR=451
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -157,5 +157,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD3")
-CR6 S DIXR=437
+CR6 S DIXR=452
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -170,5 +170,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD4")
-CR7 S DIXR=438
+CR7 S DIXR=453
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -183,5 +183,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD5")
-CR8 S DIXR=439
+CR8 S DIXR=454
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -196,5 +196,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD6")
-CR9 S DIXR=440
+CR9 S DIXR=455
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -209,5 +209,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD7")
-CR10 S DIXR=441
+CR10 S DIXR=456
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -222,5 +222,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD8")
-CR11 S DIXR=442
+CR11 S DIXR=457
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -235,5 +235,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD9")
-CR12 S DIXR=443
+CR12 S DIXR=458
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -249,5 +249,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD10")
-CR13 S DIXR=444
+CR13 S DIXR=459
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX9.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX9.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTXX9.m	(revision 636)
@@ -1,5 +1,5 @@
-DGPTXX9 ; COMPILED XREF FOR FILE #45 ; 12/12/07
+DGPTXX9 ; COMPILED XREF FOR FILE #45 ; 12/27/07
  ; 
-CR14 S DIXR=445
+CR14 S DIXR=460
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
@@ -15,5 +15,5 @@
  . K X1,X2 M X1=X,X2=X
  . D SDGPT9D^DGPTDDCR(.X,.DA,"D SD12")
-CR15 S DIXR=446
+CR15 S DIXR=461
  K X
  S DIKZ(0)=$G(^DGPT(DA,0))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREG.m	(revision 636)
@@ -1,4 +1,12 @@
-DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ; 8/24/05 1:40pm
- ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658**;Aug 13, 1993
+DGREG ;ALB/JDS,MRL/PJR/PHH-REGISTER PATIENT ;1/27/07  13:08
+ ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
 START ;
 EN D LO^DGUTL S DGCLPR=""
@@ -10,5 +18,32 @@
  I '$D(DGIO),$P(^DG(43,1,0),U,30) S %ZIS="N",IOP="HOME" D ^%ZIS I $D(IOS),IOS,$D(^%ZIS(1,+IOS,99)),$D(^%ZIS(1,+^(99),0)) S Y=$P(^(0),U,1) W !,"Using closest printer ",Y,! F I=10,"PRF","RT","HS" S DGIO(I)=Y
 A D ENDREG($G(DFN))
- W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP
+ ;
+ ; ** VOE change 1 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; if not VA agency code, add DIC("DR") to default some identifiers and
+ ; skip others also, improve readability
+ ;
+ ; before change:
+ ; W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP
+ ;
+ ; after change:
+ W !!
+ N Y,DGREGY S DGREGY=1 D  I DGREGY<0 G Q1
+ . N DIC S DIC=2 ; Patient file
+ . S DIC(0)="ALEQM" ; ask, laygo, echo, question, and multi-index
+ . N DLAYGO S DLAYGO=2 ; override file access by user: allow laygo
+ . I $G(DUZ("AG"))'="V" D  ;adjust identifiers asked for VOE
+ . . S DIC("DR")=".02;.03;994;.301///N;391///VISTA OFFICE EHR;1901///N;.09"
+ . ;
+ . D ^DIC ; Select Patient
+ . ;
+ . I Y<0 S DGREGY=-1 Q
+ . K DIC("DR")
+ . S (DFN,DA)=+Y
+ . S DGNEW=$P(Y,"^",3) ; new patient?
+ . N Y D PAUSE^DG10 ; prompt user before continuing
+ . D BEGINREG(DFN) ; lock patient record
+ ;
+ ; ** end of VOE change 1 **
  ;
  ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04
@@ -18,10 +53,29 @@
  D CIRN
  ;
- I +$G(DGNEW) D
+ ; ** VOE change 2 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ I $G(DGNEW) D NEW^DGRP ; execute new patient DR string
+ ;
+ ; send CMOR query and display results only if VA agency code
+ ;
+ ; before change:
+ ; I +$G(DGNEW) D
+ ;
+ ; after change:
+ I $G(DGNEW),$G(DUZ("AG"))="V" D
+ . ;
+ . ; end of change
+ . ;
  . ; query CMOR for Patient Record Flag Assignments if NEW patient and
  . ; display results.
  . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN)
  ;
- D ROMQRY
+ ; before change:
+ ; D ROMQRY
+ ;
+ ; after change:
+ I $G(DUZ("AG"))="V" D ROMQRY
+ ;
+ ; ** end of VOE change 2 **
  ;
  S (DGFC,CURR)=0
@@ -30,5 +84,17 @@
  D HINQ^DG10
  I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3
- D REG^IVMCQ($G(DFN))  ; send financial query  
+ ;
+ ; ** VOE change 3 of 4: DAOU/WCJ 2/1/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; send financial query only for VA agency code
+ ;
+ ; before change:
+ ; D REG^IVMCQ($G(DFN))  ; send financial query
+ ;
+ ; after change:
+ I $G(DUZ("AG"))="V" D REG^IVMCQ($G(DFN)) ; send financial query
+ ;
+ ; ** end of VOE change 3 **
+ ;
  G A1
  ;
@@ -62,4 +128,15 @@
  ;
  S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
+ ;
+ ; ** VOE change 4 of 4: DAOU/JLG 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; for VOE or IHS agency codes, add the following:
+ ; force TYPE OF CARE with ALL OTHER
+ ;
+ I $G(DUZ("AG"))="E"!($G(DUZ("AG"))="I") D
+ . S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1///5;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ
+ ;
+ ; ** end of VOE change 4 **
+ ;
  D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:2 G:'$T MSG D ^DIE L -@DGNDLOCK
  I $D(DTOUT) D  G Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAED.m	(revision 636)
@@ -1,4 +1,20 @@
-DGREGAED ;ALB/DW/PHH - Address Edit API; 9/1/2005
- ;;5.3;Registration;**522,560,658,730**;Aug 13, 1993;Build 2
+DGREGAED ;ALB/DW/PHH - Address Edit API; 1/5/2006  23:03 ;10/10/06  08:05
+ ;;5.3;Registration;**522,560,658,730,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 EN(DFN,FLG) ;Entry point
  ;Input: 
@@ -11,5 +27,5 @@
  N I,X,Y
  I $G(DFN)="" Q
- ;I ($G(DFN)'?.N) Q
+ I ($G(DFN)'?.N) Q
  S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2))
  D INPUT(.DGINPUT,DFN)
@@ -29,5 +45,19 @@
  N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,POP
  S POP=0
- F DGN=.111,.112,.113,.1112,.131,.132,.121 Q:POP  D
+ ;
+ ; ** VOE change 1 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; .134 is new field ALTERNATE PHONE for VOE
+ ;
+ ; before change:
+ ;
+ ; F DGN=.111,.112,.113,.1112,.131,.132,.121 Q:POP  D
+ ;
+ ; after change:
+ ;
+ F DGN=.111,.112,.113,.1112,.131,.132,.134,.121 Q:POP  D
+ . ;
+ . ; end change
+ . ;
  . I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) Q
  . I ($G(DGINPUT(.112))="")&(DGN=.113) Q
@@ -37,4 +67,11 @@
  .. I $G(DGR)=-1 S POP=1 Q
  .. N DGM F DGM=.1112,.114,.115,.117 S DGINPUT(DGM)=$G(DGR(DGM))
+ . ;
+ . ; new line:
+ . ;
+ . I DGN=.134,$G(DUZ("AG"))'="E" Q
+ . ;
+ . ; ** end of VOE change 1 **
+ . ;
 AGN . S DIR(0)=2_","_DGN
  . S DA=DFN
@@ -50,8 +87,26 @@
  I $G(POP)=1 S DGINPUT=-1
  Q
-COMPARE(DGINPUT,DFN) ;Display before & after address fields
+COMPARE(DGINPUT,DFN) ;Display before & after address fields.
  N DGCURR,DGN,DGCMP,DGM,DGCNTY,DGCIEN,DGST
  D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121","EI","DGCURR")
- F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121 D
+ ;
+ ; ** VOE change 2 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; for VOE agency code, add new ALTERNATE PHONE field (.134)
+ ; to DGCMP("OLD") array
+ ;
+ ; before change:
+ ;
+ ; F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121 D
+ ; . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
+ ;
+ ; after change:
+ ;
+ I $G(DUZ("AG"))="E" D GETS^DIQ(2,DFN,.134,"EI","DGCURR")
+ F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.134,.121 D
+ . I $G(DUZ("AG"))'="E",DGN=.134 Q  ; skip for non-VOE
+ . ;
+ . ; ** end of VOE change 2 **
+ . ;
  . S DGCMP("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"E"))
  S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I"))
@@ -77,4 +132,15 @@
  .. W !,?6,"   Phone: ",?16,$P($G(DGCMP(DGM,.131)),U)
  .. W !,?6,"  Office: ",?16,$P($G(DGCMP(DGM,.132)),U)
+ .. ;
+ .. ; ** VOE change 3 of 3: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 1/5/2006 **
+ .. ;
+ .. ; for VOE agency code, display new ALTERNATE PHONE field (.134)
+ .. ;
+ .. ; insert line:
+ .. ;
+ .. I $G(DUZ("AG"))="E" W !,?6," Alt Phone: ",?16,$P($G(DGCMP(DGM,.134)),U)
+ .. ;
+ .. ; ** end of VOE change 3 **
+ .. ;
  . W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U)
  . W !
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGREGAZL.m	(revision 636)
@@ -1,4 +1,4 @@
 DGREGAZL ;ALB/DW - ZIP LINKING UTILITY ; 5/27/04 10:54am
- ;;5.3;Registration;**522,560,581,730,760**;Aug 13, 1993;Build 11
+ ;;5.3;Registration;**522,560,581,730**;Aug 13, 1993;Build 2
  ;
 EN(RESULT,DFN) ;Let user edit zip+4, city, state, county based on zip-linking
@@ -43,6 +43,6 @@
  I DGZIP="" Q DGZIP
  D POSTALB^XIPUTIL(DGZIP,.DGDATA)
-  ;DG*730 - later commented out by DG*760
- ;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
+  ;DG*730
+ I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
  I $D(DGDATA("ERROR")) D  G ZAGN
  . W $C(7)," ??"
@@ -52,5 +52,5 @@
  ;   ZIP - user input zip for the patient primary address
  ;   DFN - Interal entry number of Patient File (#2)
- ; Output:RESULT=-1 (input error or timed or ^ out) 
+ ; Output:RESULT=-1 (input error or times or ^ out) 
  ;        or    =user input city
  ;        Array index # of selected city.
@@ -59,10 +59,8 @@
  N DGCITY,DGST,DGCNTY,DGABRV,DGN,DGECH,DGSOC
  N DOLDCITY,DGSAME,DGELEVEN
- ; DG*760 brought in DGCITI
- N DGCITI
  S DGIND=""
  D POSTALB^XIPUTIL(ZIP,.DGDATA)
- ;DG*730 - later commented out by DG*760
- ;I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
+ ;DG*730
+ I $G(DGDATA(1,"CITY ABBREVIATION"))'="",$G(DGDATA(1,"CITY ABBREVIATION"))=$G(DGDATA(2,"CITY")) S DGDATA=1 K DGDATA(2)
  D FIELD^DID(2,.114,"N","LABEL","DGCITY")
  S DGN=""
@@ -71,14 +69,10 @@
  . S DGSAME=0
  . F  S DGN=$O(DGDATA(DGN)) Q:DGN=""  D
- .. S DGCITI=$P($G(DGDATA(DGN,"CITY")),"*",1)
  .. S DGABRV=$G(DGDATA(DGN,"CITY ABBREVIATION"))
- .. I DOLDCITY'="",DGCITI=DOLDCITY!(DGABRV=DOLDCITY) S DGSAME=1
- .. ; next 4 commented out lines done by DG*760
- .. ;I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1)
- .. ;I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
- .. ;I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*"
- .. I $G(DGDATA(DGN,"CITY"))["*" S DGCITI=DGCITI_"*"
- .. ;S DGECH=DGN_":"_DGABRV
- .. S DGECH=DGN_":"_DGCITI
+ .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
+ .. I DGABRV="" S DGABRV=$P($G(DGDATA(DGN,"CITY")),"*",1)
+ .. I DOLDCITY'="",DGABRV=DOLDCITY S DGSAME=1
+ .. I $G(DGDATA(DGN,"CITY"))["*" S:DGABRV'="" DGABRV=DGABRV_"*"
+ .. S DGECH=DGN_":"_DGABRV
  .. S DGSOC=$S($G(DGSOC)="":DGECH,1:DGSOC_";"_DGECH)
  .. S DGTOT=DGN
@@ -111,7 +105,5 @@
  . I $D(DUOUT)!$D(DIROUT) D UPCT^DGREGAED G CAGN2
  . S RESULT=$G(Y)
- I $L($G(RESULT))>15 D
- . S DGN=Y
- . S RESULT=$G(DGDATA(DGN,"CITY ABBREVIATION"))
+ I $L($G(RESULT))>15 S RESULT=$E(RESULT,1,15)
  Q DGIND
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP1.m	(revision 636)
@@ -1,8 +1,59 @@
-DGRP1 ;ALB/MRL,ERC - DEMOGRAPHIC DATA ; 06/22/06
- ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653**;Aug 13, 1993;Build 2
+DGRP1 ;ALB/MRL - DEMOGRAPHIC DATA ;1/8/07  09:14
+ ;;5.3;Registration;**109,161,506,244,546,570,629,638,649,700,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
+ ; 2005 03 18 (VA/JT): DG*5.3*629, stop Missing Patient message based
+ ; on questionable data in Missing Person Date fld (.153).
+ ;
+ ; 2005 04 25? (VA/MRY): DG*5.3*638, add Sex to IDs shown.
+ ;
+ ; 2005 04 27 (VA/JT): DG*5.3*649, change last $EXTRACT for Alias SSN in
+ ; GETNCAL to 10 chars instead of 9, to preserve trailing P for pseudo-
+ ; SSNs.
+ ;
+ ; 2006 04 21 (WV/TOAD, after DAOU/WCJ (2005 02 07) and
+ ; VA/CJS (2005/12/23)): restore 6-part VOE change; space dots and
+ ; semi-colons.
+ ;
+ ; 2006 05 09 (WV/TOAD): rewrite VOE change to fix bugs introduced by
+ ; VA and VOE, and completely refactor bug-prone GETNCAL, and merge back
+ ; into main subroutine body.
  ;
 EN S (DGRPS,DGRPW)=1 D H^DGRPU F I=0,.11,.121,.13,.15,.24,57,"SSN" S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
  I $P(DGRP(.15),"^",2)]"" S Z="APPLICANT IS LISTED AS 'INELIGIBLE' FOR TREATMENT!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
  ;I $P(DGRP(.15),"^",3)]"" S Z="APPLICANT IS LISTED AS 'MISSING'.  NOTIFY APPROPRIATE PERSONNEL!",DGRPCM=1 D WW^DGRPV S DGRPCM=0
+ ;
+ ; ** VOE change 1 of 3 **
+ ;
+ ; if EHR agency code, display Registration Date (Date Entered into
+ ; File, .097)
+ ;
+ ; new lines:
+ I $G(DUZ("AG"))="E" D
+ . W !?58,"Reg Dt: ",$$FMTE^XLFDT($P(DGRP(0),U,16),"2D")
+ ;
+ ;
+ ; show field groups 1 and 2 in two columns
+ ;
+ ; field groups 1 & 2 part 1: show Name, SSN, and DOB
+ ;
+ ;
+ ; ** end of VOE change 1 **
+ ;
  W ! S Z=1 D WW^DGRPV W "    Name: " S Z=$P(DGRP(0),"^",1),Z1=31 D WW1^DGRPV
  W "SS: " S X=$P(DGRP(0),"^",9),Z=$E(X,1,3)_"-"_$E(X,4,5)_"-"_$E(X,6,10),Z1=13 D WW1^DGRPV
@@ -17,5 +68,110 @@
  . . Q:$G(DGREAS)']""
  . . W DGREAS
- D GETNCAL  ;Display name component, sex, and alias information
+ ;
+ ; ** VOE change 2 of 3 **
+ ;
+ ; eliminate unnecessary subroutine GETNCAL and merge code back into
+ ; the main subroutine, and make the following changes:
+ ;
+ ; For EHR or IHS agency code, show Health Record No. (.02) for the
+ ; current Facility from the Health Record No. multiple field
+ ; (4101/9000001.41) of the IHS Patient file (9000001) for the current
+ ; patient.
+ ;
+ ; Move Sex field over so it shows up in the same location for
+ ; VA, IHS, and EHR, leaving a blank for where HRN can appear.
+ ;
+ ; Fix the VA bug in which patients having five valid aliases
+ ; were showing "< More alias entries on file >" instead of the fifth
+ ; alias.
+ ;
+ ; Refactor entire subroutine: clean original design was broken
+ ; by patching and had become fragile and confusing; tighten variable
+ ; scopes, use clearer names, comment.
+ ;
+ ; before:
+ ;
+ ; D GETNCAL  ;Display name component, sex, and alias information
+ ;
+ ; after:
+ ;
+ ; field groups 1 & 2 part 2: load name components
+ ;
+ ;
+ N DGLABEL S DGLABEL="^ Given^Middle^Prefix^Suffix^Degree" ; labels
+ N DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," ; Name Components fd (1.01)
+ I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP") ; Name Components file
+ ; loads Family (Last) Name (1), Given (First) Name (2),
+ ; Middle Name (3), Prefix (4), Suffix (5), and Degree (6)
+ ;
+ ;
+ ; field groups 1 & 2 part 3: load aliases
+ ;
+ ;
+ N DGCOUNT S DGCOUNT=0 ; how many aliases do we find
+ N DGALIAS S DGALIAS=0 ; IEN of Alias subfile (1/2.01) of Patient fl (2)
+ ;                       and array of aliases found
+ S DGALIAS=0 F  D  Q:'DGALIAS
+ . ;
+ . S DGALIAS=$O(^DPT(DFN,.01,DGALIAS))
+ . Q:'DGALIAS  ; out of alias subrecords
+ . N DGNODE S DGNODE=$G(^DPT(DFN,.01,DGALIAS,0)) ; 0-node of subrecord
+ . Q:'$L(DGNODE)  ; bad node
+ . ;
+ . S DGCOUNT=DGCOUNT+1 ; another valid alias
+ . I DGCOUNT=6 S DGALIAS=0 Q  ; can't show > 5, need to know if 6 or >
+ . ;
+ . S DGALIAS(DGCOUNT)=$P(DGNODE,U) ; Alias fld (.01)
+ . ;
+ . N DGSSN S DGSSN=$P(DGNODE,U,2) ; Alias SSN fld (1)
+ . I $L(DGSSN) D
+ . . S DGSSN=" "_$E(DGSSN,1,3)_"-"_$E(DGSSN,4,5)_"-"_$E(DGSSN,6,10)
+ . . ; incl leading space to separate from alias name
+ . . ; incl 10 chars to allow for P of pseudo-SSNs
+ . . S $E(DGALIAS(DGCOUNT),20)=DGSSN ; truncate alias name & append SSN
+ . ;
+ . S DGALIAS(DGCOUNT)=$E(DGALIAS(DGCOUNT),1,32) ; truncate alias
+ ;
+ I DGCOUNT=0 S DGALIAS(1)="< No alias entries on file >"
+ I DGCOUNT=6 S DGALIAS(5)="< More alias entries on file >"
+ K DGCOUNT
+ ;
+ ;
+ ; field groups 1 & 2 part 4: show 1st name component, and IDs HRN & Sex
+ ;
+ ;
+ W !?5,"Family: "
+ W $E($G(DGCOMP(20,DGCOMP,1)),1,27)
+ ;
+ I "EI"[$G(DUZ("AG")),$G(DUZ(2)) D
+ . N DGNODE S DGNODE=$G(^AUPNPAT(DFN,41,DUZ(2),0)) ; get 0-node for the
+ . ; current Facility from the Health Record No. multiple field
+ . ; (4101/9000001.41) for DFN in the IHS Patient file (9000001)
+ . N DGHRN S DGHRN=$P(DGNODE,U,2) ; Health Record No. (.02)
+ . W ?42," HRN: ",DGHRN
+ ;
+ D
+ . N DGSEX S DGSEX=$P(DGRP(0),U,2) ; Sex fld (.02) of Patient file (2)
+ . W ?61,"Sex: ",$S(DGSEX="M":"MALE",DGSEX="F":"FEMALE",1:"UNANSWERED")
+ ;
+ ;
+ ; field groups 1 & 2 part 5: show remaining name components and aliases
+ ;
+ ;
+ N DGCOUNT F DGCOUNT=2:1:6 D
+ . W !?5,$P(DGLABEL,U,DGCOUNT),": "
+ . N DGNAME S DGNAME=$G(DGCOMP(20,DGCOMP,DGCOUNT)) ; next name component
+ . W $E(DGNAME,1,$S(DGCOUNT=2:23,1:27)) ; 1st line leaves room for "[2]"
+ . I DGCOUNT=2 D  ; header for aliases
+ . . W ?37 N DGRPW,Z S DGRPW=0,Z=2 D WW^DGRPV ; write [2], suppress LF
+ . . W " Alias: "
+ . W ?47,$G(DGALIAS(DGCOUNT-1)) ; show next alias
+ ;
+ ;
+ ; show field group 3: remarks
+ ;
+ ;
+ ; ** end of VOE change 2 **
+ ;
  S Z=3,DGRPX=DGRP(0) D WW^DGRPV W " Remarks: ",$S($P(DGRPX,"^",10)]"":$E($P(DGRPX,"^",10),1,65),1:"NO REMARKS ENTERED FOR THIS PATIENT") S DGAD=.11,(DGA1,DGA2)=1 D A^DGRPU I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,DGA1=1,DGA2=2 D A^DGRPU
  S Z=4 D WW^DGRPV W " Permanent Address: " S Z=" ",Z1=17
@@ -29,4 +185,15 @@
  S X="NOT APPLICABLE" I $P(DGRP(.121),U,9)="Y" S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD") S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD") S X=X_$S(Y]"":Y,1:DGRPU)
  W !?3,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU),?42,"From/To: ",X
+ ;
+ ; ** VOE change 3 of 3 **
+ ;
+ ; if EHR agency code, display Alternate Phone Number (.134)
+ ;
+ ; new lines:
+ I $G(DUZ("AG"))="E" D
+ . W !?1,"Alt Ph: ",$P($G(^DPT(DFN,.13)),U,4)
+ ;
+ ; ** end of VOE change 3 **
+ ;
  W !?1,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
  ;
@@ -50,34 +217,4 @@
  G ^DGRPP
  ;
-GETNCAL ;Get name component values
- N DGCOMP,DGNC,DGI,DGA,DGALIAS,DGX,DGRPW
- S DGNC="Family^Given^Middle^Prefix^Suffix^Degree"
- S DGCOMP=+$G(^DPT(DFN,"NAME"))_","
- I DGCOMP D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
- ;Get alias values
- S DGA=0 F DGI=1:1:5 D  Q:'$D(DGALIAS(DGI))
-A2 .S DGA=$O(^DPT(DFN,.01,DGA))
- .I 'DGA D:DGI=1  Q
- ..S DGALIAS(DGI)="< No alias entries on file >" Q
- .I DGI=5 S DGALIAS(DGI)="< More alias entries on file >" Q
- .S DGX=$G(^DPT(DFN,.01,DGA,0)) G:'$L(DGX) A2
- .S DGALIAS(DGI)=$P(DGX,U),DGX=$P(DGX,U,2)
- .I $L(DGX) D
- ..S DGX=" "_$E(DGX,1,3)_"-"_$E(DGX,4,5)_"-"_$E(DGX,6,9)
- ..; BAJ DG*5.3*700 retrofit 06/22/06
- ..S DGALIAS(DGI)=$E(DGALIAS(DGI),1,19)
- ..S $E(DGALIAS(DGI),20)=DGX Q
- .S DGALIAS(DGI)=$E(DGALIAS(DGI),1,32)
- .Q
- ;Display name component, sex, multiple birth indicator and alias data
- F DGI=1:1:6 D
- .W !?5,$J($P(DGNC,U,DGI),6),": ",$E($G(DGCOMP(20,DGCOMP,DGI)),1,$S(DGI=1:23,1:27))
- .I DGI=1 S (Z,DGRPW)=1 W ?43,"Sex: " S X=$P(DGRP(0),"^",2),Z=$S(X="M":"MALE",X="F":"FEMALE",1:DGRPU),Z1=3 D WW1^DGRPV
- .; BAJ DG*5.3*700 retrofit 06/2206
- .I DGI=1 S (Z,DGRPW)=1 W ?56,"MBI: " S X=$P($G(^DPT(DFN,"MPIMB")),U),Z=$S(X="N":"NO",X="Y":"*MULTIPLE BIRTH*",1:DGRPU),Z1=16 D WW1^DGRPV
- .I DGI=2 S DGRPW=0,Z=2 W ?37 D WW^DGRPV W " Alias: "
- .I DGI>1 W ?47,$G(DGALIAS(DGI-1))
- .Q
- Q
 SSNREAS(DGREAS) ;get Pseuso SSN Reason - DG*5.3*653, ERC
  S DGREAS=$P(DGRP("SSN"),U)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP14.m	(revision 636)
@@ -1,4 +1,4 @@
 DGRP14 ;ALB/MRL/EG/GAH - REGISTRATION SCREEN 14/APPOINTMENT INFORMATION ; 10/18/06
- ;;5.3;Registration;**568,585,725,770**;Aug 13, 1993;Build 4
+ ;;5.3;Registration;**568,585,725**;Aug 13, 1993;Build 12
  S DGRPS=14 D H^DGRPU S (Z,DGRPW)=1 D WW^DGRPV W " Enrollment Clinics: "
  S I1=""
@@ -17,5 +17,5 @@
  .;check to see if appointment is cancelled, if so
  .;ignore this appointment eg 01/25/2005
- .;I $$CANCEL(DFN,APTDT)="Y" Q TAKEN OUT IN PATCH 770.
+ .I $$CANCEL(DFN,APTDT)="Y" Q
  .S CLNAM=$P($P(^TMP($J,"SDAMA301",DFN,APTDT),U,2),";",2)
  .S X=$S(CLNAM]"":CLNAM,1:"UNKNOWN CLINIC")_" ("_$$FMTE^DILIBF(APTDT,"5U")_"), " W:(79-$X)<$L(X) !?24 W X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP2.m	(revision 636)
@@ -1,4 +1,20 @@
-DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ;06 JUN 88@2300
- ;;5.3;Registration;**415,545,638,677,760**;Aug 13, 1993;Build 11
+DGRP2 ;ALB/MRL,BRM - REGISTRATION SCREEN 2/CONTACT INFORMATION ; 1/5/2006  23:54
+ ;;5.3;Registration;**415,545,638,677,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  S DGRPS=2 D H^DGRPU F I=0,.24,57,1010.15 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
  S DGRPX=DGRP(0)
@@ -9,9 +25,42 @@
  ;S DGRPX=DGRP(0)
  W !?4,"Religion: ",$S($D(^DIC(13,+$P(DGRPX,"^",8),0)):$P(^(0),"^",1),1:DGRPU),?41,"Father: ",$S($P(DGRP(.24),"^",1)]"":$E($P(DGRP(.24),"^",1),1,29),1:DGRPU)
- S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QP"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X
+ S X=$P(DGRP(57),"^",4),X=$S(X']"":DGRPU,X="X":"NOT APPLICABLE",X=1:"PARA,",X=2:"QUAD,",X=3:"PARA,NON",1:"QUAD,NON"),X=$S("QD"[$E(X):X_"TRAUMATIC",1:X) W !?9,"SCI: ",X
  W ?41,"Mother: ",$S($P(DGRP(.24),"^",2)]"":$E($P(DGRP(.24),"^",2),1,29),1:DGRPU)
  W !,?35,"Mom's Maiden: ",$S($P(DGRP(.24),"^",3)]"":$E($P(DGRP(.24),"^",3),1,29),1:DGRPU)
- W ! S Z=2 D WW^DGRPV W " Previous Care Date      Location of Previous Care",!?4,"------------------      -------------------------" S DGRPX=DGRP(1010.15) I $P(DGRPX,"^",5)'="Y" S X="NONE INDICATED" W !?4,X,?28,X
- E  F I=1:1:4 S I1=$P(DGRPX,"^",I) X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)" I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
+ ;
+ ; ** start of VOE change: DAOU,VA/CJS,WV/TOAD 1/5/2006 **
+ ;
+ ; New VOE Patient fields
+ ;
+ ; insert 7 lines:
+ ;
+ I $G(DUZ("AG"))="E" D
+ . W !?4,"Veteran: ",$$GET1^DIQ(2,DFN,19902)
+ . W !,"Interpreter Language: "
+ . N IL S IL=""
+ . N I F I=1:1 S IL=$O(^DPT(DFN,19901,"B",IL)) Q:IL=""  D
+ . . I I'=1 W ","
+ . . W $$GET1^DIQ(.85,IL,1)
+ ;
+ ; next three groups of lines have been conditionalized to only display
+ ; for VA agency code; also, refactored for clarity
+ ;
+ I $G(DUZ("AG"))="V" D
+ . W ! S Z=2 D WW^DGRPV
+ . W " Previous Care Date      Location of Previous Care"
+ . W !?4,"------------------      -------------------------"
+ . S DGRPX=DGRP(1010.15)
+ . ;
+ . I $P(DGRPX,"^",5)'="Y" D
+ . . S X="NONE INDICATED"
+ . . W !?4,X,?28,X
+ . ;
+ . E  F I=1:1:4 D
+ . . S I1=$P(DGRPX,"^",I)
+ . . X "I I#2 S Y=I1 X:Y]"""" ^DD(""DD"") W !?4,$S(Y]"""":Y,1:DGRPU)"
+ . . I '(I#2) W ?28,$S($D(^DIC(4,+I1,0)):$P(^(0),"^",1),1:DGRPU)
+ ;
+ ; ** end of VOE change **
+ ;
  W ! S Z=3 D WW^DGRPV W " Ethnicity: " D
  .I '$O(^DPT(DFN,.06,0)) W "UNANSWERED" Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRP3.m	(revision 636)
@@ -1,4 +1,20 @@
-DGRP3 ;ALB/MRL - REGISTRATION SCREEN 3/CONTACT INFORMATION ;06 JUN 88@2300
- ;;5.3;Registration;;Aug 13, 1993
+DGRP3 ;ALB/MRL - REGISTRATION SCREEN 3/CONTACT INFORMATION ;11/5/06  20:31
+ ;;5.3;Registration;**634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  S DGRPW=1,DGRPS=3 D H^DGRPU F I=.21,.211,.33,.331,.34 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
  S DGAD=.21,DGA1=3,DGA2=1 D:$P(DGRP(.21),"^",1)]"" AL^DGRPU(24) S DGAD=.211,DGA1=3,DGA2=2 D:$P(DGRP(.211),"^",1)]"" AL^DGRPU(27)
@@ -11,4 +27,11 @@
  F I=0:0 S I=$O(DGA(I)) Q:'I  S Z="              "_$E(DGA(I),1,27) W !,Z
  W !?7,"Phone: ",$P(X,"^",3),?41,"Work Phone: ",$P(X,"^",4)
+ ;New EHR code    ;DAOU/WCJ  2/7/05
+ ;New fields for agency EHR
+ I $G(DUZ("AG"))="E" S DGRPW=0,Z=6 W ! D WW^DGRPV S DGRPI=$G(^DPT(DFN,19900)) D
+ .W "Year arrived in U.S.: ",$P(DGRPI,"^",6),!
+ .W "Mother's Country of Birth: ",$P(DGRPI,"^",4),!
+ .W "Father's Country of Birth: ",$P(DGRPI,"^",5),!
+ ;End EHR modifications
 Q K DGRPI,DGRPI1
  G ^DGRPP
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPCE.m	(revision 636)
@@ -1,4 +1,20 @@
-DGRPCE ;ALB/MRL,KV,PJR,BRM,ERC - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am
- ;;5.3;Registration;**121,122,175,297,342,451,626,689,653**;Aug 13, 1993;Build 2
+DGRPCE ;ALB/MRL,KV,PJR,BRM - CONSISTENCY CHECKER, EDIT INCONSISTENCIES ; 12/14/04 9:42am
+ ;;5.3;Registration;**121,122,175,297,342,451,626,689,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
  ;KV;11/15/00;DG*5.3*297;Disable addition of CD Elig Code in Reg. Screens
@@ -9,4 +25,8 @@
  S DGEK=0 F I=9,10,11,12,13,14,18,19,20,22,24,36,51 Q:DGEK  I DGER[(","_I_",") S DGEK=1 Q
  I 'DGKEY(1) D:DGEK ELDR S I=15 D SASK S I=23 D SASK
+ ;New EHR code  DAOU/WCJ  2/5/05
+ ;skip veteran related fields for agency EHR
+ G NKEY:$G(DUZ("AG"))="E"
+ ;End EHR new code 
  F I=29,30,31,32,33,43,44,45,48,56 D SASK,MON:DGCCF S DGCCF=0
  G NKEY:DGKEY(3) F I=25,26,27,28,34,35 D SASK
@@ -39,7 +59,13 @@
  S DGDRC=DGDRC+1,DGDR="DR(1,2,"_DGDRC_")",@DGDR=DGD,DGD="" Q
 ELDR S DGASK=DGASK_"9,10,11,12,13,14,18,19,20,24,29,30,31,34,36,37,38,"
- I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
- I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
- D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
+ ;Previous VA code prior to EHR changes
+ ;I 'DGKEY(1) S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
+ ;I 'DGKEY(2) F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
+ ;D:DGD]"" SAVE I 'DGKEY(3) S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
+ ;New code  DAOU/WCJ 2/5/05  Skip veteran specific fields
+ I 'DGKEY(1),$G(DUZ("AG"))'="E"  S DGD="391;1901;S DGVTYN=$S($D(^DPT(DFN,""VET"")):$P(^(""VET""),""^"",1),1:"""");S:X'=""Y"" Y=""@1"";.301;S:X'=""Y"" Y=""@1"";.302;@1;" D SAVE
+ I 'DGKEY(2),$G(DUZ("AG"))'="E"  F I=29,30,31 S DGD=$P($T(@I),";;",2,999) D SAVE
+ D:DGD]"" SAVE I 'DGKEY(3),$G(DUZ("AG"))'="E"  S DGD=$P($T(34),";;",2,999) D SAVE S DGD=$P($T(51),";;",2,999) D SAVE
+ ;End new code  DAOU/WCJ  2/5/05
  I 'DGKEY(1) D ELIG^DGRPCE1
  Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPD.m	(revision 636)
@@ -1,12 +1,10 @@
-DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ; 3/9/06 11:17am
- ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703**;Aug 13, 1993
+DGRPD ;ALB/MRL/MLR/JAN/LBD/EG/BRM/JRC-PATIENT INQUIRY (NEW) ;1/27/07  13:14
+ ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA
+ ; GPL Copyright (C) 2007 WorldVistA
  ;  *286*  Newing variables X,Y in OKLINE subroutine
- ;  *358*  If a patient is on a domiciliary ward, don't display MEANS
- ;         TEST required/Medication Copayment Exemption messages
- ;  *436*  If an inpatient is not on a domiciliary ward, don't display
- ;         Medication Copayment Exemption message
- ;  *545*  Add death information near the remarks field
- ;  *677*  Added Emergency Response
+ ;  
 SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
+ ;
 EN ;call to display patient inquiry - input DFN
  ;MPI/PD CHANGE
@@ -51,7 +49,14 @@
  .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0))  W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
  I '$$OKLINE(16) G Q
- ;display cv status #4156
- N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
- W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
+ ;
+ ; VOE change
+ ;
+ I DUZ("AG")="V" D
+ . ;display cv status #4156
+ . N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
+ . W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
+ ;
+ ; end VOE change
+ ;
  ;display primary eligibility
  S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
@@ -111,6 +116,16 @@
 HDR I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
  ;MPI/PD CHANGE
- W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
+ ; VOE CHANGE
+ ; W @IOF,!,$P(VADM(1),"^",1),?40,$P(VADM(2),"^",2),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
+ W @IOF,!,$P(VADM(1),"^",1),?32,$P(VADM(2),"^",2),?50,$$HRNV(DFN),?65,$P(VADM(3),"^",2) S X="",$P(X,"=",78)="" W !,X,!?15,"COORDINATING MASTER OF RECORD: ",DGCMOR,! Q
  ;END MPI/PD CHANGE
+HRNV(DFN) ;
+ N IRET
+ S IRET=$$HRN^DGLBPID(DFN)
+ I IRET="#" Q ""
+ S IRET="HRN "_IRET
+ Q IRET
+ ; END VOE CHANGE
+ ;
 INP S VAIP("D")="L" D INP^DGPMV10
  S DGPMT=0
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPDB.m	(revision 636)
@@ -1,4 +1,4 @@
 DGRPDB ;ALB/AAS,JAN,ERC,PHH - VIEW ONLY SCREEN TO DETERMINE BILLING ELIGIBILITY ; 3/23/06 8:16am
- ;;5.3;Registration;**26,50,358,570,631,709,713,749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;**26,50,358,570,631,709,713**;Aug 13, 1993
  ;
 % S:'$D(DGQUIT) DGQUIT=0
@@ -62,13 +62,7 @@
  ;
 AOIR ;Agent Orange/ionizing radiation
- N DGEC,NTA
  S DGX=$S($D(^DPT(DFN,.321)):^(.321),1:"")
  F I=2,3 S X=$P(DGX,"^",I) W:I=2 !,"           A/O Exp.: " W:I=3 "ION Rad.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED"),"   "
  S X=$G(^DPT(DFN,.38)),X1=$P(X,"^",1) W "Medicaid Elig: ",$S(X1="":"NOT ANSWERED",'X1:"NO",1:"YES") I ($X+15)'>IOM W " - " S Y=$P(X,"^",2) D D^DIQ W $P(Y,"@")
- S DGEC=$S($D(^DPT(DFN,.322)):^DPT(DFN,.322),1:"")
- S X=$P(DGEC,U,13) W !,"        Env Contam.: " W $S(X="Y":"YES",X="N":"NO",X="U":"UNKNOWN",1:"NOT ANSWERED"),"   "
- S NTA=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
- K DGNTARR
- W "N/T Radium: " W $S(NTA'="":NTA,1:"NOT ANSWERED")
  Q
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPE.m	(revision 636)
@@ -1,4 +1,19 @@
-DGRPE ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ; 09/12/05 1:27pm
- ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735**;Aug 13, 1993;Build 11
+DGRPE ;ALB/MRL,LBD,BRM,TMK - REGISTRATIONS EDITS ;1/27/07  13:11
+ ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ;
+ ; VOE changes: DAOU,VA/CJS,WV/TOAD 5/9/2006
+ ; conditionally add edit fields to the following lines:
+ ;    201: Is Patient a Veteran (19902), Interpreter Language (19906)
+ ;    202: skip line if agency code for IHS or VOE
+ ; 305002+1: for VOE, Mother's Country of Birth (19903), Father's Country
+ ;         of Birth (19904), Year Arrived in U.S. (19905)
  ;
  ;DGDR contains a string of edits; edit=screen*10+item #
@@ -53,4 +68,6 @@
  Q
  ;
+ ; VOE changes at lines 201, 202, 304 & after 305002
+ ;
 SETFLDS(DGDR) ; Set up fields to edit
  Q
@@ -66,6 +83,6 @@
 111000 ;;K DR(2,2.141);.1411;I X']"" W !?4,$C(7),"I need at least one line of Address." S Y=.14105;.1412;S:X']"" Y=.1414;.1413;.1414;.1415;.1416;Q;.14111;@111;K DIE("NO^");
 112 ;;.134;.135;.133
-201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;
-202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
+201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE;;S:$G(DUZ("AG"))'="E" Y="@21";19902;19906;@21
+202 ;;S:"IE"[$G(DUZ("AG")) Y="@22";1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
 203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
 205 ;;.181;
@@ -82,4 +99,5 @@
 305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381
 305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2;
+ ;;S:$G(DUZ("AG"))'="E" Y="@36";19903;19904;19905;@36401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
 401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
 402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPECE.m	(revision 636)
@@ -1,4 +1,20 @@
-DGRPECE ;ALB/MRY,ERC - REGISTRATION CATASTROPHIC EDITS ; 10/4/06 2:35pm
- ;;5.3;Registration;**638,682,700,720,653**;Aug 13, 1993;Build 2
+DGRPECE ;ALB/MRY - REGISTRATION CATASTROPHIC EDITS ;1/6/07  13:28
+ ;;5.3;Registration;**638,682,700,720,653,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
 CEDITS(DFN) ;catastrophic edits  - buffer values, save after check
@@ -37,5 +53,6 @@
  S DIR(0)="2,.09^^"
  S DA=DFN D ^DIR
- I $D(DIRUT) D CECHECK Q
+ I $D(DIRUT),DUZ("AG")="V" D CECHECK Q  ; VOE modification, SSN may be null
+ I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
  S BUFFER("SSN")=Y
  ;if SSN is pseudo, Pseudo SSN Reason is req. - DG*5.3*653, ERC
@@ -62,10 +79,12 @@
  S DIR(0)="2,.03^^"
  S DA=DFN D ^DIR
- I $D(DIRUT) D CECHECK Q
+ I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
+ I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
  S BUFFER("DOB")=Y
 SEX ;buffer - get sex
  S DIR(0)="2,.02^^"
  S DA=DFN D ^DIR
- I $D(DIRUT) D CECHECK Q
+ I $D(DIRUT),DUZ("AG")="V" D CECHECK Q
+ I $D(DTOUT)!$D(DUOUT) D CECHECK Q  ; VOE modification
  S BUFFER("SEX")=Y
 MBI ; buffer - get MBI (multiple birth indicator)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TEMPLATE(#1476), FILE 2;04/10/06
+DGRPTX ; GENERATED FROM 'DGRPT 10-10T REGISTRATION' INPUT TEMPLATE(#1476), FILE 2;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -106,5 +106,5 @@
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
  I $D(DE(4))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C4F1 N X,X1,X2 S DIXR=643 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
+C4F1 N X,X1,X2 S DIXR=664 D C4X1(U) K X2 M X2=X D C4X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^DPT("APTYPE",X,DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX1 ; ;04/10/06
+DGRPTX1 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX10.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX10 ; ;04/10/06
+DGRPTX10 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -62,5 +62,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X1 K:$L(X)>30!($L(X)<1) X I $D(X) S DFN=DA D K1^DGLOCK2
@@ -77,5 +77,5 @@
 C3S S X="" G:DG(DQ)=X C3F1 K DB
 C3F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X3 I $D(X),X="Y" S DFN=DA D K1^DGLOCK2
@@ -99,5 +99,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C5F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X5 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
@@ -122,5 +122,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C7F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X7 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
@@ -137,5 +137,5 @@
 C9S S X="" G:DG(DQ)=X C9F1 K DB
 C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X9 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
@@ -153,5 +153,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C10F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X10 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D K1^DGLOCK2
@@ -170,5 +170,5 @@
  D:($T(ADGRU^DGRUDD01)'="") ADGRU^DGRUDD01(DA)
 C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X11 I $D(X) S DFN=DA D K1^DGLOCK2
@@ -186,5 +186,5 @@
  D SET^DGREGDD1(DA,.218,.21,8,$E(X,1,5))
 C12F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X12 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D K1^DGLOCK2 I $D(X) K:$L(X)>15!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX11.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX11 ; ;04/10/06
+DGRPTX11 ; ;04/21/06
  S X=DE(13),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX12.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX12 ; ;04/10/06
+DGRPTX12 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF=".219;" D AVAFC^VAFCDD01(DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX13.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX13 ; ;04/10/06
+DGRPTX13 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -60,5 +60,5 @@
 C1S S X="" G:DG(DQ)=X C1F1 K DB
 C1F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X1 I $D(X),X="Y" D K1^DGLOCK2
@@ -97,5 +97,5 @@
  Q
 C6F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X6 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NAME)=$$FORMAT^XLFNAME7(.DG20NAME,3,35) K:'$L(X) X,DG20NAME
@@ -112,5 +112,5 @@
 C8S S X="" G:DG(DQ)=X C8F1 K DB
 C8F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X8 K:$L(X)>30!($L(X)<2) X I $D(X) S DFN=DA D E1^DGLOCK2
@@ -128,5 +128,5 @@
  ;
 C9F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X9 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
@@ -147,5 +147,5 @@
  ;
 C11F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X11 K:X[""""!($A(X)=45) X I $D(X) K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
@@ -162,5 +162,5 @@
 C13S S X="" G:DG(DQ)=X C13F1 K DB
 C13F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X13 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
@@ -174,5 +174,5 @@
 C14S S X="" G:DG(DQ)=X C14F1 K DB
 C14F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X14 K:$L(X)>30!($L(X)<3) X I $D(X) S DFN=DA D E1^DGLOCK2
@@ -187,5 +187,5 @@
 C15S S X="" G:DG(DQ)=X C15F1 K DB
 C15F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X15 I $D(X) S DFN=DA D E1^DGLOCK2
@@ -201,5 +201,5 @@
  D ^DGRPTX15
 C16F1 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=607 S DIEZRXR(2,DIXR)=""
+ F DIXR=604 S DIEZRXR(2,DIXR)=""
  Q
 X16 K:X[""""!($A(X)=45) X I $D(X) S DFN=DA D E1^DGLOCK2 I $D(X) K:$L(X)>15!($L(X)<5) X I $D(X) D ZIPIN^VAFADDR
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX14.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX14 ; ;04/10/06
+DGRPTX14 ; ;04/21/06
  S X=DE(16),DIC=DIE
  D KILL^DGREGDD1(DA,.338,.33,8,$E(X,1,5))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX15.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX15 ; ;04/10/06
+DGRPTX15 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  D SET^DGREGDD1(DA,.338,.33,8,$E(X,1,5))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX16.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX16 ; ;04/10/06
+DGRPTX16 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -143,5 +143,5 @@
  S X=DG(DQ),DIC=DIE
  D EVENT^IVMPLOG(DA)
-C6F1 N X,X1,X2 S DIXR=627 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
+C6F1 N X,X1,X2 S DIXR=646 D C6X1(U) K X2 M X2=X D C6X1("O") K X1 M X1=X
  D
  . D FC^DGFCPROT(.DA,2,.525,"KILL",$H,$G(DUZ),.X,.X1,.X2,$G(XQY0)) Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX17.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX17 ; ;04/10/06
+DGRPTX17 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX18.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX18 ; ;04/10/06
+DGRPTX18 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.301,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.301,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX19.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX19 ; ;04/10/06
+DGRPTX19 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX2.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX2 ; ;04/10/06
+DGRPTX2 ; ;04/21/06
  S X=DE(9),DIC=DIE
  X "S DGXRF=.112 D ^DGDDC Q"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX20.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX20 ; ;04/10/06
+DGRPTX20 ; ;04/21/06
  S X=DE(11),DIC=DIE
  X ^DD(2,.36205,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX21.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX21 ; ;04/10/06
+DGRPTX21 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX22.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX22 ; ;04/10/06
+DGRPTX22 ; ;04/21/06
  S X=DE(12),DIC=DIE
  X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX23.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX23 ; ;04/10/06
+DGRPTX23 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX24.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX24 ; ;04/10/06
+DGRPTX24 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX25.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX25 ; ;04/10/06
+DGRPTX25 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX26.m	(revision 636)
@@ -1,5 +1,5 @@
-DGRPTX26 ; ;04/10/06
+DGRPTX26 ; ;04/21/06
  ;;
-1 N X,X1,X2 S DIXR=605 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=602 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  D
  . D PNOK^DGDDDTTM
@@ -20,5 +20,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=607 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=604 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  D
  . D ECON^DGDDDTTM
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX27.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX27 ; ;08/13/05
+DGRPTX27 ; ;12/08/05
  D DE G BEGIN
 DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX28.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX28 ; ;08/13/05
+DGRPTX28 ; ;12/08/05
  S X=DE(8),DIC=DIE
  K ^DPT("APOS",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX29.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX29 ; ;08/13/05
+DGRPTX29 ; ;12/08/05
  S X=DG(DQ),DIC=DIE
  S ^DPT("APOS",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX3.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX3 ; ;04/10/06
+DGRPTX3 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX30.m	(revision 636)
@@ -1,5 +1,5 @@
-DGRPTX30 ; ;08/13/05
+DGRPTX30 ; ;12/08/05
  ;;
-1 N X,X1,X2 S DIXR=605 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=602 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  D
  . D PNOK^DGDDDTTM
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX4.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX4 ; ;04/10/06
+DGRPTX4 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX5.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX5 ; ;04/10/06
+DGRPTX5 ; ;04/21/06
  S X=DE(5),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX6.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX6 ; ;04/10/06
+DGRPTX6 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX7.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX7 ; ;04/10/06
+DGRPTX7 ; ;04/21/06
  S X=DE(7),DIC=DIE
  K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DPT(D0,.11)):^(.11),1:""),Y=$P(Y(1),U,7) X:$D(^DD(2,.117,2)) ^(2) S X=Y S DIU=X K Y S X=DIV S X="" X ^DD(2,.115,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX8.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX8 ; ;04/10/06
+DGRPTX8 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  ;
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPTX9.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPTX9 ; ;04/10/06
+DGRPTX9 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -189,5 +189,5 @@
  Q
 C6F2 S DIEZRXR(2,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=605 S DIEZRXR(2,DIXR)=""
+ F DIXR=602 S DIEZRXR(2,DIXR)=""
  Q
 X6 K:$L(X)>35!($L(X)<3) X I $D(X) S DG20NAME=X,(X,DG20NAME)=$$FORMAT^XLFNAME7(.DG20NAME,3,35) K:'$L(X) X,DG20NAME
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPU.m	(revision 636)
@@ -1,4 +1,20 @@
-DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;19 OCT 2005
- ;;5.3;Registration;**33,114,489,624,672,689**;Aug 13, 1993;Build 1
+DGRPU ;ALB/MRL,TMK - REGISTRATION UTILITY ROUTINE ;12/25/06  18:28
+ ;;5.3;Registration;**33,114,489,624,672,689,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 H ;Screen Header
  I DGRPS'=1.1 W @IOF S Z=$P($T(H1+DGRPS),";;",2)_", SCREEN <"_DGRPS_">"_$S($D(DGRPH):" HELP",1:""),X=79-$L(Z)\2 D W
@@ -165,6 +181,30 @@
  Q
 SSNNM(DFN) ; SSN and name on first line of screen
- N X,SSN
- S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
+ ;
+ ; ** start of VOE change: DAOU/JLG 2/1/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; Change code so it will display HRN if SSN is null
+ ;
+ ; before:
+ ;
+ ; N X,SSN
+ ; S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
+ ;
+ ; after:
+ ;
+ ; Social Security Number field (.09) in Patient file (2)
+ N X,SSN,HRN
+ S X=$S($D(^DPT(+DFN,0)):^(0),1:""),SSN=$P(X,"^",9)
+ I SSN S SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,10)
+ ;
+ID S SSN=$$ID^DGLBPID(DFN) ;**GFT/VW
+ ; for IHS or EHR, replace SSN with HRN
+ I $G(DUZ("AG"))'="V" D
+ . Q:SSN]""
+ . S HRN=$$HRN^AUPNPAT3(+DFN,DUZ(2))
+ . I HRN S SSN="HRN-"_HRN
+ ;
+ ; ** end of VOE change **
+ ;
  S X=$P(X,U)_"; "_SSN
  Q X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPV.m	(revision 636)
@@ -1,4 +1,20 @@
 DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA - REGISTRATION DEFINE VARIABLES ON ENTRY ; 8/11/05 12:56pm
- ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716**;Aug 13, 1993
+ ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
  ;
  ;
@@ -29,4 +45,12 @@
  . S DGRPVV="000000000000000"
  S X="5^3^5^2^3^8^4^2^10^2^4^5^5^2^1"
+ ;
+ ; ** VOE change 1 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; new line: if agency code is not VA, new section added to screen 3
+ I $G(DUZ("AG"))'="V" S $P(X,"^",3)="6"
+ ;
+ ; ** end of VOE change 1 **
+ ;
  F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
  S DGRPVV(1.1)="00"
@@ -41,4 +65,14 @@
  ;-- commented the line to allow screens 2 & 4 to display for Tricare
  ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
+ ;
+ ; ** VOE change 2 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; add lines: if agency code is not VA, change last screen to 14,
+ ; and clear flag for screen 15 (it is VA-specific)
+ I $G(DUZ("AG"))'="V" D
+ . S DGRPLAST=14
+ . F I=15 S DGRPVV=$E(DGRPVV,0,I-1)_$S(I=15:"",1:1)_$E(DGRPVV,I+1,99)
+ ;
+ ; ** end of VOE change 2 **
  ;
  F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99)  I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
@@ -58,4 +92,13 @@
  F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
  S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
+ ;
+ ; ** VOE change 3 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; add line: if agency code is not VA, only edit one section of screen 7
+ ; The rest is veteran specific.
+ I $G(DUZ("AG"))'="V" S DGRPVV(7)="1101"
+ ;
+ ; ** end of VOE change 3 **
+ ;
  I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
  I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
@@ -69,4 +112,13 @@
  I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=1000
  S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
+ ;
+ ; ** VOE change 4 of 4: DAOU/WCJ 2/7/2005,VA/CJS,WV/TOAD 5/9/2006 **
+ ;
+ ; add line: if agency code is not VA, and last screen is set to 15, set
+ ; it to 14 (it is VA-specific)
+ I $G(DUZ("AG"))'="V",DGRPLAST=15 S DGRPLAST=14
+ ;
+ ; ** end of VOE change 4 **
+ ;
  I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
 Q K DGRPSC,DGRPSCE
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX7.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLATE(#420), FILE 2;06/27/07
+DGRPX7 ; GENERATED FROM 'DG LOAD EDIT SCREEN 7' INPUT TEMPLATE(#420), FILE 2;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -70,5 +70,5 @@
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
  I $D(DE(2))'[0!(^DD(DP,DIFLD,"AUDIT")'="e") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET
-C2F1 N X,X1,X2 S DIXR=643 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X
+C2F1 N X,X1,X2 S DIXR=664 D C2X1(U) K X2 M X2=X D C2X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^DPT("APTYPE",X,DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX71.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX71 ; ;06/27/07
+DGRPX71 ; ;12/27/07
  S X=DE(9),DIC=DIE
  D AUTOUPD^DGENA2(DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX710.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX710.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX710.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX710 ; ;06/27/07
+DGRPX710 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX711.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX711.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX711.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX711 ; ;06/27/07
+DGRPX711 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,""E"",",DIC=DIE,DP=2.0361,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,"E",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX712.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX712.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX712.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX712 ; ;06/27/07
+DGRPX712 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S A1B2TAG="PAT" D ^A1B2XFR
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX713.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX713.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX713.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX713 ; ;06/27/07
+DGRPX713 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,.373,",DIC=DIE,DP=2.05,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.373,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX714.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX714.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX714.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX714 ; ;12/28/06
+DGRPX714 ; ;01/18/07
  D DE G BEGIN
 DE S DIE="^DPT(D0,.373,",DIC=DIE,DP=2.05,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.373,DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX72.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX72 ; ;06/27/07
+DGRPX72 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  D AUTOUPD^DGENA2(DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX73.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX73 ; ;06/27/07
+DGRPX73 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX74.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX74 ; ;06/27/07
+DGRPX74 ; ;12/27/07
  S X=DE(11),DIC=DIE
  X ^DD(2,.36235,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX75.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX75 ; ;06/27/07
+DGRPX75 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36235,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(2,.36235,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX76.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX76 ; ;06/27/07
+DGRPX76 ; ;12/27/07
  S X=DE(12),DIC=DIE
  X ^DD(2,.3025,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,2.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX77.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX77 ; ;06/27/07
+DGRPX77 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.3025,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.3)):^(.3),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(2,.3025,1,1,1.4)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX78.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX78 ; ;06/27/07
+DGRPX78 ; ;12/27/07
  S X=DE(14),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRPX79.m	(revision 636)
@@ -1,3 +1,3 @@
-DGRPX79 ; ;06/27/07
+DGRPX79 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA01.m	(revision 636)
@@ -1,4 +1,4 @@
-DGRUGA01 ;ALB/GRR - HL7 ADT A01 MESSAGE BUILDER ; 11/27/07 1:43pm
- ;;5.3;Registration;**190,303,762**;Aug 13, 1993;Build 3
+DGRUGA01 ;ALB/GRR - HL7 ADT A01 MESSAGE BUILDER ;06/08/99
+ ;;5.3;Registration;**190,303**;Aug 13, 1993
  ;
  ;This routine will build a ADT A01 (Admit) HL7 message for an inpatient.
@@ -36,5 +36,4 @@
  .S:DGPCPNM="" DGPCPNM=HL("Q")
  .S $P(DGPV1,HL("FS"),8)=DGPCPPTR_$E(HL("ECH"))_DGPCPNM
- .K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
  .;Get current ward & room/bed
  .S DGW=$$GET1^DIQ(2,DFN,.1,"I")
@@ -50,5 +49,4 @@
  I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT) S $P(@DGARRAY@(1),HL("FS"),7)=$$HLDATE^HLFNC(DGOADT)
  S DGPV1=$$DOCID^DGRUUTL(DGPV1)
- K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
  ;TRANSLATE WARD AND ROOM-BED NAMES IF NEEDED (ALREADY DONE IF SEEDING)
  S:'$G(DGSEED) DGPV1=$$LOCTRAN^DGRUUTL1(DGPV1)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA08.m	(revision 636)
@@ -1,4 +1,4 @@
-DGRUGA08 ;ALB/GRR - HL7 ADT A08 MESSAGE BUILDER ; 10/11/07 9:24am
- ;;5.3;Registration;**190,312,328,721,762**;Aug 13, 1993;Build 3
+DGRUGA08 ;ALB/GRR - HL7 ADT A08 MESSAGE BUILDER ; 21 Sep 2006  8:24 AM
+ ;;5.3;Registration;**190,312,328,721**;Aug 13, 1993;Build 3
  ;
  ;This routine will build a ADT A08 (Patient Update) HL7 message for an inpatient.
@@ -16,5 +16,5 @@
  N DGPV1,DGHOLD,DGCNT,DGMDT,DGCDT,DGOADT,DGIN1,DGLMT,DGZEL,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
  Q:DGARRAY=""  ;Required output variable name was not passed
- K @DGARRAY ;Kill output array to insure erroneous data does not exist
+ K @DGARRAY ;Kill output array to insure erronuous data does not exist
  I DGMIEN="" N VAIP D NOW^%DTC S VAIP("D")=% D IN5^VADPT S DGMIEN=$G(VAIP(1)) K VAIP Q:DGMIEN=""  ;changed p-328
  D NOW^%DTC S DGCDT=$$HLDATE^HLFNC(%) ;Get current date/time and convert to HL7 format
@@ -33,5 +33,4 @@
  I $G(DGLMT)=1,$E($G(DGDC))="D" S $P(DGPV1,HL("FS"),4)=$P(DGPV1,HL("FS"),7) ;This is a change to a prior HL7, move prior location to current
  N VAIP D IN5^VADPT S $P(DGPV1,HL("FS"),11)=$$GET1^DIQ(45.7,+VAIP(8),1,"I") K VAIP ; p-721
- K ATTDOC S ATTDOC=$$ATTDOC^DGRUUTL(.ATTDOC) S $P(DGPV1,HL("FS"),18)=ATTDOC K ATTDOC ; P-762
  S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1)
  S DGCNT=DGCNT+1 ;Increment node counter to store next segment
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGA22.m	(revision 636)
@@ -1,4 +1,4 @@
-DGRUGA22 ;ALB/GRR - HL7 ADT A22 MESSAGE BUILDER ; 11/7/07 3:45pm
- ;;5.3;Registration;**190,762**;Aug 13, 1993;Build 3
+DGRUGA22 ;ALB/GRR - HL7 ADT A22 MESSAGE BUILDER ;8/5/99  15:36
+ ;;5.3;Registration;**190**;Aug 13, 1993
  ;
  ;This routine will build a ADT A22 (From Leave of Absence) HL7 message for an inpatient.
@@ -14,5 +14,5 @@
  N DGPV1,DGCNT,DGMDT,DGCDT,DGOADT,DGICD,DGICDCNT,DGIN,DGINCNT S DGCNT=0
  Q:DGARRAY=""  ;Required output variable name was not passed
- K @DGARRAY ;Kill output array to insure erroneous data does not exist
+ K @DGARRAY ;Kill output array to insure erronuous data does not exist
  Q:DGMIEN=""
  S DGMDT=$$GET1^DIQ(405,DGMIEN,".01","I")
@@ -28,5 +28,4 @@
  I DGOADT]"" S $P(DGPV1,HL("FS"),45)=$$HLDATE^HLFNC(DGOADT)
  S DGPV1=$$DOCID^DGRUUTL(DGPV1)
- N VAIP,DGW,DGRM D IN5^VADPT S DGW=$P(VAIP(5),"^",2),DGRM=$P(VAIP(6),"^",2),$P(DGPV1,HL("FS"),4)=DGW_$E(HLECH)_DGRM K VAIP ; P-762
  S @DGARRAY@(DGCNT)=$$LOCTRAN^DGRUUTL1(DGPV1) ;Translate Ward and Room-Bed name, store into array
  S DGMTYP=$$GET1^DIQ(405,DGMIEN,.18,"I") ;Get Movement Type
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUGBJ.m	(revision 636)
@@ -1,4 +1,4 @@
-DGRUGBJ ; ALB/SCK - RAI/MDS COTS ADT Background job ; 11/7/07 3:49pm
- ;;5.3;Registration;**190,312,357,762**;Aug 13, 1993;Build 3
+DGRUGBJ ; ALB/SCK - RAI/MDS COTS ADT Background job ; 8-10-99
+ ;;5.3;Registration;**190,312,357**;Aug 13, 1993
  ;
 EN ; Main Entry point for patient demographic update to COTS system
@@ -26,6 +26,5 @@
  . ; Check for patient, if not valid, then mark as transmitted and quit
  . I ('$D(^DPT(DFN,0))) D XMITFLAG^VAFCDD01(PVTPTR,"",1) Q
- . N VAIN D INP^VADPT ; p-762
- . I '$$CHKWARD^DGRUUTL(+VAIN(4)) D XMITFLAG^VAFCDD01(PVTPTR,"",1) K VAIN Q  ; P-762
+ . ;
  . K @DGARRAY
  . S @DGARRAY@("PIVOT")=PVTPTR
@@ -94,5 +93,5 @@
  Q (HLRST)
  ;
-ERRBUL(EVNTINFO,RESULT) ; Generate bulletin if an error occurred while building the HL7 message.
+ERRBUL(EVNTINFO,RESULT) ; Generate bulliten if an error occurred while building the HL7 message.
  ;
  N XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGRUUTL.m	(revision 636)
@@ -1,4 +1,4 @@
-DGRUUTL ;ALB/GRR - RAI/MDS UTILITY ROUTINE ; 10/11/07 8:42am
- ;;5.3;Registration;**190,444,762**;Aug 13, 1993;Build 3
+DGRUUTL ;ALB/GRR - RAI/MDS UTILITY ROUTINE
+ ;;5.3;Registration;**190,444**;Aug 13, 1993
 HLNAME(DGNAME) ;Piece apart name into LAST NAME_"^"_FIRST NAME_"^"_MIDDLE NAME_"^"_SUFFIX
  ;Input DGNAME - Either Last Name, First or First, Middle and Last Name (i.e. SMITH,JOHN R   or  JOHN R SMITH)
@@ -39,8 +39,5 @@
  ;
  ;  Returns the medicaid information from the patient file
- ; P-762 return Medicaid number or 'N'
- N A S A=$$GET1^DIQ(2,DFN,.383)
- S:A="" A="N"
- Q A
+ Q $$GET1^DIQ(2,DFN,.383)
  ;
 GETAMOV(DFN) ;GET LAST ADMISSION MOVEMENT FOR A PATIENT
@@ -88,7 +85,2 @@
 EXITDOC Q X
  ;
-ATTDOC(X) ;get attending physician - p-762
- N ATTPTR,ATTNAME,VAIP D IN5^VADPT S ATTPTR=$P(VAIP(18),"^",1),ATTNAME=$P(VAIP(18),"^",2) K VAIP
- I $L(ATTPTR)>6 S ATTPTR=$E(ATTPTR,$L(ATTPTR)-5,$L(ATTPTR))
- I $G(ATTNAME) S ATTNAME=$$HLNAME(ATTNAME)
- Q ATTPTR_$E(HL("ECH"))_ATTNAME
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F ; GENERATED FROM 'DG501F' INPUT TEMPLATE(#429), FILE 45;09/05/07
+DGX5F ; GENERATED FROM 'DG501F' INPUT TEMPLATE(#429), FILE 45;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(",DIC=DIE,DP=45,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DGPT(DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F1.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F1 ; ;09/05/07
+DGX5F1 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
@@ -63,5 +63,5 @@
  S ^DGPT(DA(1),"M","AM",$E(X,1,30),DA)=""
 C2F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=447,448,449,450,451,452,453,454,455,456 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=462,463,464,465,466,467,468,469,470,471 S DIEZRXR(45.02,DIXR)=""
  Q
 X2 S %DT="ETX" D ^%DT S X=Y K:Y<1 X I $D(X) X $S(X<$P(^DGPT(DA(1),0),U,2):"W !,""Not before admission"" K X",X>($S($D(^(70)):$S(+^(70):+^(70),1:9999999),1:9999999)):"W !,""Not after discharge"" K X",1:"")
@@ -154,5 +154,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C25F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=447 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=462 S DIEZRXR(45.02,DIXR)=""
  Q
 X25 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=5 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -175,5 +175,5 @@
  D ^DGX5F3
 C29F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=448 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=463 S DIEZRXR(45.02,DIXR)=""
  Q
 X29 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=6 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F2.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F2 ; ;09/05/07
+DGX5F2 ; ;12/27/07
  S X=DE(29),DIC=DIE
  K ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F3.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F3 ; ;09/05/07
+DGX5F3 ; ;12/27/07
  S X=DG(DQ),DIC=DIE
  S ^DGPT(DA(1),"M","AC",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F4.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F4.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F4.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F4 ; ;09/05/07
+DGX5F4 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
@@ -66,5 +66,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C1F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=449 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=464 S DIEZRXR(45.02,DIXR)=""
  Q
 X1 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=7 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -93,5 +93,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C5F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=450 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=465 S DIEZRXR(45.02,DIXR)=""
  Q
 X5 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=8 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
@@ -120,5 +120,5 @@
  X "N X S X=""DGRUDD01"" X ^%ZOSF(""TEST"") Q:'$T  N DG1 S DG1=+$P(^DGPT(DA(1),0),""^"",1) D:(DG1>0) ADGRU^DGRUDD01(DG1)"
 C9F1 S DIEZRXR(45.02,DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))
- F DIXR=451 S DIEZRXR(45.02,DIXR)=""
+ F DIXR=466 S DIEZRXR(45.02,DIXR)=""
  Q
 X9 D ICDEN^DGPTF5 Q:X=""  K K S DIC("S")="S DGI=9 D EN^DGPTFJC I 'DGER" S DIC(0)=$P(DIC(0),"E")_$P(DIC(0),"E",2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F5.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F5.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F5.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F5 ; ;09/05/07
+DGX5F5 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F6.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F6.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F6.m	(revision 636)
@@ -1,3 +1,3 @@
-DGX5F6 ; ;09/05/07
+DGX5F6 ; ;12/27/07
  D DE G BEGIN
 DE S DIE="^DGPT(D0,""M"",",DIC=DIE,DP=45.02,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DGPT(D0,"M",DA,""))=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F7.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F7.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGX5F7.m	(revision 636)
@@ -1,5 +1,5 @@
-DGX5F7 ; ;09/05/07
+DGX5F7 ; ;12/27/07
  ;;
-1 N X,X1,X2 S DIXR=447 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
+1 N X,X1,X2 S DIXR=462 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD1")
@@ -12,5 +12,5 @@
  S X=$G(X(1))
  Q
-2 N X,X1,X2 S DIXR=448 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
+2 N X,X1,X2 S DIXR=463 D X2(U) K X2 M X2=X D X2("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD2")
@@ -23,5 +23,5 @@
  S X=$G(X(1))
  Q
-3 N X,X1,X2 S DIXR=449 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
+3 N X,X1,X2 S DIXR=464 D X3(U) K X2 M X2=X D X3("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD3")
@@ -34,5 +34,5 @@
  S X=$G(X(1))
  Q
-4 N X,X1,X2 S DIXR=450 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
+4 N X,X1,X2 S DIXR=465 D X4(U) K X2 M X2=X D X4("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD4")
@@ -45,5 +45,5 @@
  S X=$G(X(1))
  Q
-5 N X,X1,X2 S DIXR=451 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
+5 N X,X1,X2 S DIXR=466 D X5(U) K X2 M X2=X D X5("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD5")
@@ -56,5 +56,5 @@
  S X=$G(X(1))
  Q
-6 N X,X1,X2 S DIXR=452 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
+6 N X,X1,X2 S DIXR=467 D X6(U) K X2 M X2=X D X6("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD6")
@@ -67,5 +67,5 @@
  S X=$G(X(1))
  Q
-7 N X,X1,X2 S DIXR=453 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
+7 N X,X1,X2 S DIXR=468 D X7(U) K X2 M X2=X D X7("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD7")
@@ -78,5 +78,5 @@
  S X=$G(X(1))
  Q
-8 N X,X1,X2 S DIXR=454 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
+8 N X,X1,X2 S DIXR=469 D X8(U) K X2 M X2=X D X8("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD8")
@@ -89,5 +89,5 @@
  S X=$G(X(1))
  Q
-9 N X,X1,X2 S DIXR=455 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
+9 N X,X1,X2 S DIXR=470 D X9(U) K X2 M X2=X D X9("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD9")
@@ -100,5 +100,5 @@
  S X=$G(X(1))
  Q
-10 N X,X1,X2 S DIXR=456 D X10(U) K X2 M X2=X D X10("F") K X1 M X1=X
+10 N X,X1,X2 S DIXR=471 D X10(U) K X2 M X2=X D X10("F") K X1 M X1=X
  I $G(X(1))]"",$G(X(2))]"" D
  . D KDGPT9M^DGPTDDCR(.X,.DA,"M ICD10")
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DPTLK.m	(revision 636)
@@ -1,4 +1,12 @@
-DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ; 3/22/05 4:19pm
- ;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647**;Aug 13, 1993
+DPTLK ;ALB/RMO,RTK - MAS Patient Look-up Main Routine ;1/27/07  13:12
+ ;;5.3;Registration;**32,72,93,73,136,157,197,232,265,277,223,327,244,513,528,541,576,600,485,633,629,647,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
  ;
  ; mods made for magstripe read 12/96 - JFP
@@ -8,4 +16,6 @@
  ;
 EN ; -- Entry point
+ ;Following line so VOE will use alternate lookup routine, DAOU,VA/CJS,WV/TOAD
+ I $G(DUZ("AG"))'="V" D ^AUPNLK Q
  N DIE,DR
  K DPTX,DPTDFN,DPTSAVX I $D(DIC(0)) G QK:DIC(0)["I"!(DIC(0)'["A"&('$D(X)))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADATE.m	(revision 636)
@@ -1,8 +1,8 @@
 VADATE ;ALB/MLI - GENERIC DATE ROUTINE ; 1 DEC 88 @1000
- ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;;Aug 13, 1993
  ;
  I $D(VADAT("F")),$S(VADAT("F")<1:1,VADAT("F")>2:1,1:0) K VADAT("F")
- I '$D(VADAT("W")) S VANOW=$$NOW^XLFDT
- S VA=$S('$D(VADAT("W")):VANOW,1:VADAT("W")),(VA,VADATE("I"))=$S($D(VADAT("S")):VA,'$D(VADAT("T")):$E(VA,1,12),1:$P(VA,".",1))
+ I '$D(VADAT("W")) D NOW^%DTC
+ S VA=$S('$D(VADAT("W")):%,1:VADAT("W")),(VA,VADATE("I"))=$S($D(VADAT("S")):VA,'$D(VADAT("T")):$E(VA,1,12),1:$P(VA,".",1))
  S:'$D(VADAT("H")) (VA(1),VA(2),VA(3))=1 I $D(VADAT("H")) F I=1:1:3 S VA(I)=$S(VADAT("H")[I:1,1:0)
  S VAM=$S('$E(VA,4,5):"",'VA(2):"",$S('$D(VADAT("F")):1,VADAT("F")=2:1,1:0):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(VA,4,5)),1:$E(VA,4,5)),VAY=$S(VA(3):(1700+$E(VA,1,3)),1:""),VAD=$S(VA(1)&$E(VA,6,7):$E(VA,6,7),1:"")
@@ -13,4 +13,4 @@
  S VADATE("E")=VADATE("E")_$S(VA(3):$E(VAY,3,4),1:"")_$S($D(VAT):"@"_VAT,1:"")
 QUIT I $D(VADAT("J")),VADAT("J")?.N F I=$L(VADATE("E"))+1:1:VADAT("J") S VADATE("E")=" "_VADATE("E")
- K %DT,VA,VAD,VADEL,VAM,VAT,VAX,VAY,VANOW Q
+ K %DT,VA,VAD,VADEL,VAM,VAT,VAX,VAY Q
 KVAR K VADAT,VADATE Q
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m	(revision 636)
@@ -1,4 +1,20 @@
-VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ; 08 DEC 1988 ; 11/9/04 6:17pm
- ;;5.3;Registration;**415,489,516,614**;Aug 13, 1993
+VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ;1/27/07  15:00
+ ;;5.3;Registration;**415,489,516,614,634**;Aug 13, 1993;Build 28
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 1 ;Demographic [DEM]
  N W,Z,NODE
@@ -15,4 +31,16 @@
  ; -- age [4 - AG]
  S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
+ ;
+ ; Added for VOE to support pediatrics
+ ;
+ I @VAV@($P(VAS,"^",4))<2 D  ;IHS/ANMC/CLS 01/20/2005
+ .N X,X1,X2,X3
+ .S X1=$S('$G(^DPT(DFN,.35)):DT,1:+^(.35))
+ .S X2=$P(VAX,"^",3) Q:'X1!('X2)
+ .D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,X<31:X_" DYS",1:X\30_" MOS")
+ .S @VAV@($P(VAS,"^",4))=X Q
+ ;
+ ; End VOE addition
+ ;
  ;
  ; -- expired date [6 - EX]
@@ -52,4 +80,14 @@
  S @VAV@($P(VAS,"^",12))=Y-1
  Q
+ ;
+ ; Added for VOE to support pediatrics
+ ;
+PAGE ; -- IHS printable age  ;IHS/ITSC/CLS 01/14/2005
+ N X,X1,X2,Y,AUX
+ S X1=$S('$D(^DPT(DFN,.35)):DT,1:+^(.35))
+ S X2=$P(VAX,"^",3) D:X2 ^%DTC:X1 S AUX=X\365.25,X=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
+ S @VAV@($P(VAS,"^",4))=X Q
+ ;
+ ; End addition for VOE & IHS
  ;
 2 ;Other Patient Variables [OPD]
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT2.m	(revision 636)
@@ -1,6 +1,6 @@
 VADPT2 ;ALB/MJK - ESTABLISH PATIENT VARIABLES ; 3/23/88  9:13 PM ; [10/20/95 4:02pm]
- ;;5.3;Registration;**69,749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;**69**;Aug 13, 1993
 5 ; -- INP call
- S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" S VANOW=$$NOW^XLFDT K VAMV,VAMV0
+ S (VAWD,VATS,VADX,VAPP,VAAP,VARM)="" D NOW^%DTC S VANOW=% K VAMV,VAMV0
  I '$D(VAINDT) N VAINDT S VAINDT=VANOW
  S VATD=9999999.999999-VAINDT
@@ -54,5 +54,5 @@
  ;
 ADM ; -- send back adm ifn for dfn on vaindt or now
- S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT  S VADT=$$NOW^XLFDT
+ S VADT=$S($D(VAINDT):VAINDT,1:"") I 'VADT D NOW^%DTC S VADT=%
  S VAID=9999999.999999-VADT,VADMVT=""
  F  S VAID=$O(^DGPM("ATID1",DFN,VAID)) Q:'VAID  S VAMV=+$O(^DGPM("ATID1",DFN,VAID,0)) I $D(^DGPM(VAMV,0)) S VAMV0=^(0),VAMV1=$S($D(^DGPM(+$P(VAMV0,"^",17),0)):^(0),1:9999999.999999) D  Q:VADMVT!($P(VAMV0,U,18)'=40)
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT3.m	(revision 636)
@@ -1,7 +1,7 @@
 VADPT3 ;ALB/MRL - PATIENT VARIABLES [IN5]; 12 DEC 1988 ; 7/22/03 5:00pm
- ;;5.3;Registration;**532,749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;**532**;Aug 13, 1993
  ;Inpatient variables [Version 5.0 and above]
 6 ;
- S (NOW,VAX("DAT"))=$$NOW^XLFDT,NOWI=9999999.999999-NOW
+ D NOW^%DTC S (NOW,VAX("DAT"))=%,NOWI=9999999.999999-%
  ;
  I $D(VAIP("E")),$D(^DGPM(+VAIP("E"),0)) S VAX("DT")=+^(0),E=+VAIP("E") G GO ;Specific Entry
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT5.m	(revision 636)
@@ -1,4 +1,4 @@
 VADPT5 ;ALB/MRL/MJK - PATIENT VARIABLES [REG]; 14 DEC 1988 ; 8/6/04 7:42am
- ;;5.3;Registration;**54,63,242,584,749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;**54,63,242,584**;Aug 13, 1993
 10 ;Registration/Disposition [REG]
  N VARPSV
@@ -27,7 +27,7 @@
  ;
 12 ;Appointments [SDA]
- N VASDSV,SDCNT,SDARRAY,VANOW
- S VANOW=$$NOW^XLFDT
- S VASDSV("F")=$S($G(VASD("F"))?7N.E:VASD("F"),1:VANOW)
+ N VASDSV,SDCNT,SDARRAY
+ D NOW^%DTC
+ S VASDSV("F")=$S($G(VASD("F"))?7N.E:VASD("F"),1:%)
  S VASDSV("T")=$S(+$G(VASD("T")):+VASD("T"),1:9999999) I '$P(VASDSV("T"),".",2) S $P(VASDSV("T"),".",2)=999999
  S VASDSV("W")=$S('$G(VASD("W")):12,1:VASD("W"))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m	(revision 636)
@@ -1,4 +1,4 @@
 VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
- ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;;Aug 13, 1993
  ;
 1 ;;ID Format Enter/Edit
@@ -26,9 +26,9 @@
  ;
 BEG ;
- S VASTART=$$NOW^XLFDT
+ D NOW^%DTC S VASTART=%
  Q
  ;
 END ;
- S VAEND=$$NOW^XLFDT,L=0
+ D NOW^%DTC S VAEND=%,L=0
  K XMY
  S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCPID.m	(revision 636)
@@ -1,4 +1,4 @@
 VAFCPID ;ALB/MLI,PKE-Create generic PID segment ; 21 Nov 2002  3:13 PM
- ;;5.3;Registration;**91,149,190,415,508,749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;**91,149,190,415,508**;Aug 13, 1993
  ;
  ; This routine returns the HL7 defined PID segment with its
@@ -21,5 +21,5 @@
  ;          variables may be altered.
  ;
- N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
+ N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,VAPA ; calls VADPT...have to NEW
  S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
  S DFN=$G(DFN)
@@ -41,7 +41,5 @@
  S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
  ;Mother's maiden name (#6)
- I VAFSTR[",6," D
- .S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
- .S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
+ I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ)
  ;Date of birth (#7)
  I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFCTF.m	(revision 636)
@@ -1,4 +1,4 @@
 VAFCTF ;BIR/DLR-Utility for capturing patient's Date Last Treated and Event Reason ;9/9/2002
- ;;5.3;Registration;**428,713,766**;Aug 13, 1993;Build 3
+ ;;5.3;Registration;**428,713**;Aug 13, 1993
  Q  ; quit if called from the top
  ;
@@ -71,8 +71,4 @@
  . Q
  K VAFCDATA,VAFCPURG,VAFCX,VAFCX1,VAFCX2
- ;DG*5.3*766
- I $E(VAFCX3,9,10)>23 S VAFCX3=$E(VAFCX3,1,8)_"23"_$E(VAFCX3,11,14)
- I $E(VAFCX3,11)>5 S VAFCX3=$E(VAFCX3,1,10)_"59"_$E(VAFCX3,13,14)
- ;DG*5.3*713
  I $E(VAFCX3,13)>5 S VAFCX3=$E(VAFCX3,1,12)_"59"
  Q VAFCX3_"^5" ; X is either null or the date/time of the check out
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPID.m	(revision 636)
@@ -1,4 +1,4 @@
 VAFHLPID ;ALB/MLI/ESD - Create generic PID segment ; 21 Nov 2002  3:13 PM
- ;;5.3;Registration;**68,94,415,508,749**;Aug 13, 1993;Build 10
+ ;;5.3;Registration;**68,94,415,508**;Aug 13, 1993
  ;
  ; This routine returns the HL7 defined PID segment with its
@@ -26,5 +26,5 @@
  ;          variables may be altered.
  ;
- N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,DGMMN,VAPA ; calls VADPT...have to NEW
+ N I,VAFY,VA,VADM,X,X1,Y,OUTPUT,DGNAME,VAPA ; calls VADPT...have to NEW
  S VAFSTR=$G(VAFSTR) ; if not defined, just return required fields
  S DFN=$G(DFN)
@@ -50,7 +50,5 @@
  S X=$$HLNAME^XLFNAME(.DGNAME,"",$E(HLECH)),VAFY(5)=$S(X]"":X,1:HLQ)
  ;Mother's maiden name (#6)
- I VAFSTR[",6," D
- .S DGMMN("FILE")=2,DGMMN("IENS")=DFN,DGMMN("FIELD")=.2403
- .S X=$$HLNAME^XLFNAME(.DGMMN,"",$E(HLECH)),VAFY(6)=$S(X]"":X,1:HLQ)
+ I VAFSTR[",6," S X=$P($G(^DPT(DFN,.24)),"^",3),VAFY(6)=$S(X]"":X,1:HLQ)
  ;Date of birth (#7)
  I VAFSTR[",7," S VAFY(7)=$$HLDATE^HLFNC(+VADM(3))
Index: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPR1.m
===================================================================
--- FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPR1.m	(revision 631)
+++ FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VAFHLPR1.m	(revision 636)
@@ -1,4 +1,4 @@
 VAFHLPR1 ;ALB/ESD - Create generic HL7 PR1 Segment ;4/4/00
- ;;5.3;Registration;**94,123,160,215,243,606**;Aug 13, 1993
+ ;;5.3;Registration;**94,123,160,215,243,606**;Aug 13, 1993;Build 1
  ;06/22/99 ACS - Added CPT modifier API calls and added CPT modifier to the
  ;PR1 segment (sequence 16)
Index: FOIAVistA/tag/r/RPC_BROKER-XWB/XWBDLOG.m
===================================================================
--- FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBDLOG.m	(revision 631)
+++ FOIAVistA/tag/r/RPC_BROKER-XWB/XWBDLOG.m	(revision 636)
@@ -1,3 +1,3 @@
-XWBDLOG ;ISF/RWF - Debug Logging for Broker ;12/08/2004  08:54
+XWBDLOG ;ISF/RWF - Debug Logging for Broker ;08/04/2004  13:56
  ;;1.1;RPC BROKER;**35**;Mar 28, 1997
  Q
@@ -5,5 +5,4 @@
  ;Setup the log, Clear the log location.
 LOGSTART(RTN) ;Clear the debug log
- Q:'$G(XWBDEBUG)
  K ^XTMP("XWBLOG"_$J)
  S ^XTMP("XWBLOG"_$J,0)=$$HTFM^XLFDT($$HADD^XLFDT($H,7))_"^"_$$DT^XLFDT
Index: FOIAVistA/tag/r/RPC_BROKER-XWB/XWBRW.m
===================================================================
--- FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBRW.m	(revision 631)
+++ FOIAVistA/tag/r/RPC_BROKER-XWB/XWBRW.m	(revision 636)
@@ -1,4 +1,21 @@
-XWBRW ;ISF/RWF - Read/Write for Broker TCP ;08/03/2004  15:09
- ;;1.1;RPC BROKER;**35**;Mar 28, 1997
+XWBRW ;ISF/RWF - Read/Write for Broker TCP ;8/16/07  09:33
+ ;;1.1;RPC BROKER;**35,49**;Mar 28, 1997;Build 4;WorldVistA 30-Jan-08
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  Q
  ;
@@ -15,5 +32,5 @@
  . S S=L-$L(R),R=R_$E(XWBRBUF,1,S),XWBRBUF=$E(XWBRBUF,S+1,999999)
  . I ($L(R)=L)!(R[$C(4))!(C>TO) S DONE=1 Q
- . R XWBRBUF:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0
+ . R XWBRBUF#S:2 S:'$T C=C+1 S:$L(XWBRBUF) C=0 I +$DEVICE S DONE=1
  . I $G(XWBDEBUG)>2,$L(XWBRBUF) D LOG^XWBDLOG("rd: "_$E(XWBRBUF,1,252))
  . Q
Index: FOIAVistA/tag/r/RPC_BROKER-XWB/XWBTCPL.m
===================================================================
--- FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBTCPL.m	(revision 631)
+++ FOIAVistA/tag/r/RPC_BROKER-XWB/XWBTCPL.m	(revision 636)
@@ -1,3 +1,3 @@
-XWBTCPL ;SLC/KCM - Listener for TCP connects ;12/09/2004  07:33
+XWBTCPL ;SLC/KCM - Listener for TCP connects ;08/25/2004  12:08
  ;;1.1;RPC BROKER;**1,7,9,15,16,35**;Mar 28, 1997
  ;ISC-SF/EG - DHCP Broker
@@ -136,5 +136,4 @@
  . D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
  . Q
- S XWBDEBUG=$G(XWBDEBUG)
  ;Set new trap
  S $ETRAP="Q:($ESTACK&'$QUIT)  Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPL"
Index: FOIAVistA/tag/r/RPC_BROKER-XWB/XWBTCPM.m
===================================================================
--- FOIAVistA/trunk/r/RPC_BROKER-XWB/XWBTCPM.m	(revision 631)
+++ FOIAVistA/tag/r/RPC_BROKER-XWB/XWBTCPM.m	(revision 636)
@@ -1,4 +1,4 @@
-XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;01/04/2006  62562.56228
- ;;1.1;RPC BROKER;**35,43**;Mar 28, 1997
+XWBTCPM ;ISF/RWF - BROKER TCP/IP PROCESS HANDLER ;8/29/07  22:11
+ ;;1.1;RPC BROKER;**35,43,49**;Mar 28, 1997;Build 6
  ;Based on: XWBTCPC & XWBTCPL, Modified by ISF/RWF
  ;Changed to be started by UCX or %ZISTCPS
@@ -38,5 +38,5 @@
  ;GTM specific code
  S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
- S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter)"
+ S XWBTDEV=$P X "U XWBTDEV:(nowrap:nodelimiter:ioerror=""TRAP"")"
  S %="",@("%=$ZTRNLNM(""REMOTE_HOST"")") S:$L(%) IO("GTM-IP")=%
  G CONNTYPE
@@ -44,4 +44,5 @@
 ESET ;Set inital error trap
  S U="^",$ETRAP="D ^%ZTER H" ;Set up the error trap
+ S X="",@^%ZOSF("TRAP") ;Clear old trap
  Q
  ;Find the type of connection and jump to the processing routine.
@@ -155,5 +156,5 @@
  D ^%ZTER ;%ZTER clears $ZE and $ZCODE
  D LOG("In ETRAP: "_XWBERC) ;Log
- I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") D EXIT HALT
+ I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F")!(XWBERC["IOEOF") D EXIT HALT
  U XWBTDEV
  I $G(XWBT("PCNT")) L ^XUTL("XUSYS",$J,0)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC14.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCAPMC14.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC14.m	(revision 636)
@@ -1,4 +1,4 @@
 SCAPMC14 ;ALB/REW - Team API's: PTPR ; JUN 30, 1995
- ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41**;AUG 13, 1993
  ;;1.0
 PTPR(SC200,SCDATES,SCPURPA,SCROLEA,SCLIST,SCERR,SCYESCL) ; -- list patients for a pract (scyescl NOT supported)
@@ -67,10 +67,7 @@
  .Q:'SCOK
  .Q:'SCYESCL
- .;S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
- .;Q:'SC44
- .N CNAME,SC44
- .D SETASCL^SCRPRAC2(SCTP,.CNAME,.SC44)
- .N SCCNT S SCCNT=0
- .F  S SCCNT=$O(SC44(SCCNT)) Q:SCCNT=""  S SCOK=$$PTCL^SCAPMC(SC44(SCCNT),"SCDTPR",.SCLIST,.SCERR)
+ .S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9)
+ .Q:'SC44
+ .S SCOK=$$PTCL^SCAPMC(SC44,"SCDTPR",.SCLIST,.SCERR)
 PRACQ Q $G(@SCERR@(0))<1
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC29.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCAPMC29.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC29.m	(revision 636)
@@ -1,4 +1,4 @@
 SCAPMC29 ;ALB/REW - TEAM APIs:CLPT  ; 2/17/00 1:33pm
- ;;5.3;Scheduling;**41,210,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,210**;AUG 13, 1993
  ;;1.0
 CLPT(DFN,SCDATES,SCTEAMA,SCLIST,SCERR) ;clinics for patient
@@ -48,25 +48,25 @@
  .F SCX=1:1 S SCTP=+$G(SCPOSAX(SCX)) Q:'SCTP  S SCPOSA(SCTP)=""
  .S:$D(@SCTEAMA@("EXCLUDE")) SCPOSA("EXCLUDE")=""
- ;S SCX=0 F  S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX  D
- ;.S SC44=+$G(^DPT(DFN,"DE",SCX,0))
- ;.Q:'SC44
- ;.Q:'$$OKCLIN(SC44,.SCPOSA)
- ;.S SCCLNM=$P($G(^SC(SC44,0)),U,1)
- ;.S SCS=0 F  S SCS=$O(^DPT(DFN,"DE",SCX,1,SCS)) Q:'SCS  D
- ;..S SCND=$G(^DPT(DFN,"DE",SCX,1,SCS,0))
- ;..S SCACT=$P(SCND,U,1)
- ;..S SCINACT=$P(SCND,U,3)
- ;..Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT,SCINACT)
- ;..S SCACOPT=$P(SCND,U,2)
- ;..S SCREVDT=$P(SCND,U,5)
- ;..S SCN=$G(@SCLIST@(0),0)+1
- ;..;bp/ar nois brx-1298-12323 prevent undefined variable error
- ;..;New code begins
- ;..Q:'SCACT
- ;..Q:'SCN
- ;.;End of brx-1298-12323
- ;..S @SCLIST@(0)=SCN
- ;..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT
- ;..S @SCLIST@("SCCL",SC44,SCACT,SCN)=""
+ S SCX=0 F  S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX  D
+ .S SC44=+$G(^DPT(DFN,"DE",SCX,0))
+ .Q:'SC44
+ .Q:'$$OKCLIN(SC44,.SCPOSA)
+ .S SCCLNM=$P($G(^SC(SC44,0)),U,1)
+ .S SCS=0 F  S SCS=$O(^DPT(DFN,"DE",SCX,1,SCS)) Q:'SCS  D
+ ..S SCND=$G(^DPT(DFN,"DE",SCX,1,SCS,0))
+ ..S SCACT=$P(SCND,U,1)
+ ..S SCINACT=$P(SCND,U,3)
+ ..Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT,SCINACT)
+ ..S SCACOPT=$P(SCND,U,2)
+ ..S SCREVDT=$P(SCND,U,5)
+ ..S SCN=$G(@SCLIST@(0),0)+1
+ ..;bp/ar nois brx-1298-12323 prevent undefined variable error
+ ..;New code begins
+ ..Q:'SCACT
+ ..Q:'SCN
+ ..;End of brx-1298-12323
+ ..S @SCLIST@(0)=SCN
+ ..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT
+ ..S @SCLIST@("SCCL",SC44,SCACT,SCN)=""
 PTCLQ Q $G(@SCERR@(0))<1
  ;
@@ -75,5 +75,5 @@
  IF '$D(SCPOSA) S SCOK=1 G QTOKC
  S (SCOK,SCTP)=0
- F  S SCTP=$O(^SCTM(404.57,"E",+SC44,SCTP)) Q:'SCTP  S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1
+ F  S SCTP=$O(^SCTM(404.57,"D",+SC44,SCTP)) Q:'SCTP  S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1
 QTOKC Q SCOK
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC30.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCAPMC30.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC30.m	(revision 636)
@@ -1,4 +1,4 @@
 SCAPMC30 ;ALB/REW - TEAM APIs:TPCL  ; 30 Jun 95
- ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41**;AUG 13, 1993
  ;;1.0
 TPCL(SC44,SCDATES,SCPOSA,SCUSRA,SCPURPA,SCROLEA,SCLIST,SCERR) ;  -- list of positions for a clinic
@@ -58,5 +58,5 @@
  S SCOK=1
  G:'$$OKDATA CLTPQ
- S SCTP=0 F  S SCTP=$O(^SCTM(404.57,"E",SC44,SCTP)) Q:'SCTP  D  Q:'SCOK
+ S SCTP=0 F  S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:'SCTP  D  Q:'SCOK
  .S SCTP0=$G(^SCTM(404.57,SCTP,0))
  .IF '$L(SCTP0) D
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC9.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCAPMC9.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCAPMC9.m	(revision 636)
@@ -1,4 +1,4 @@
 SCAPMC9 ;ALB/REW - Team API's:PRCL ; JUN 26, 1995
- ;;5.3;Scheduling;**41,112,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,112**;AUG 13, 1993
  ;;1.0
 PRCL(SC44,SCDATES,SCPOSA,SCUSRA,SCROLEA,SCLIST,SCERR) ;-- list of practitioners for clinic
@@ -54,5 +54,5 @@
  ; -- loop through team positions
  S SCTP=0
- F  S SCTP=$O(^SCTM(404.57,"E",SC44,SCTP)) Q:SCTP=""  D
+ F  S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:SCTP=""  D
  .Q:'$$OKARRAY^SCAPU1(.SCPOSA,SCTP)
  .S SCND=$G(^SCTM(404.57,SCTP,0))
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCDD2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCDD2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCDD2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996
- ;;5.3;Scheduling;**41,107,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,107**;AUG 13, 1993
  ;1
 USEPCDEF(SCCL) ;how should pc practitioner be used for clinic
@@ -24,5 +24,5 @@
  S SCOK=0
  S SCXTP=0
- F  S SCXTP=$O(^SCTM(404.57,"E",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP)  D
+ F  S SCXTP=$O(^SCTM(404.57,"D",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP)  D
  .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q
  .S SCOK=1
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLB1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCHLB1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLB1.m	(revision 636)
@@ -1,4 +1,4 @@
-SCMCHLB1 ;BPOI/DJB - PCMM HL7 Bld Segment Array Cont.;8/17/99
- ;;5.3;Scheduling;**177,515,524**;08/17/99;Build 29
+SCMCHLB1 ;BP/DJB - PCMM HL7 Bld Segment Array Cont. ; 8/17/99 9:29am
+ ;;5.3;Scheduling;**177,515**;May 01, 1999;Build 14
  ;
 SEGMENTS(DFN,SUB) ;Build EVN & PID segments
@@ -46,13 +46,13 @@
  ;   Array of ZPC segments
  ;
- NEW DATA,DATE,ID,ID1,LINETAG,SUB,TYPE,VAFZPC
+ NEW DATA,DATE,ID,ID1,LINETAG,NUM,TYPE,VAFZPC
  ;
- S SUB=0
- F  S SUB=$O(ARRAY(SUB)) Q:'SUB  D  ;
+ S NUM=0
+ F  S NUM=$O(ARRAY(NUM)) Q:'NUM  D  ;
  . S TYPE=""
- . F  S TYPE=$O(ARRAY(SUB,TYPE)) Q:TYPE=""  D  ;
+ . F  S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE=""  D  ;
  .. S ID=""
- .. F  S ID=$O(ARRAY(SUB,TYPE,ID)) Q:ID=""  D  ;
- ... S DATA=$G(ARRAY(SUB,TYPE,ID))
+ .. F  S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID=""  D  ;
+ ... S DATA=$G(ARRAY(NUM,TYPE,ID))
  ... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment
  ... E  D  ;....................A ZPC segment with data
@@ -74,6 +74,8 @@
  ....S DATA=DATA_"^"_ROLE
  ... ;
- ... D BLDZPC^SCMCHLS ;..Build segment ; og/sd/524
- ... D CPYZPC^SCMCHLS ;..Copy segment into array ; og/sd/524
+ ... S LINETAG="BLDZPC"
+ ... D @LINETAG^SCMCHLS ;..Build segment
+ ... S LINETAG="CPYZPC"
+ ... D @LINETAG^SCMCHLS ;..Copy segment into array
  Q
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLB2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCHLB2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLB2.m	(revision 636)
@@ -1,4 +1,4 @@
-SCMCHLB2 ;BPOI/DJB - PCMM HL7 Bld Segment Array Deletes;3/6/00
- ;;5.3;Scheduling;**177,204,210,224,524**;08/13/93;Build 29
+SCMCHLB2 ;BP/DJB - PCMM HL7 Bld Segment Array Deletes ; 3/6/00 8:41am
+ ;;5.3;Scheduling;**177,204,210,224**;AUG 13, 1993
  ;
 PTP ;Entry has been deleted from file 404.43. Send deletes to NPCD.
@@ -20,6 +20,5 @@
  S ID=PTPI_"-"
  F  S ID=$O(^SCPT(404.49,"B",ID)) Q:ID=""!($P(ID,"-",1)'=PTPI)  D  ;
- . N SUB  ; og/sd/524
- . S SUB=PTPI,DATA="^^^" ;........A Delete type ZPC segment
+ . S DATA="^^^" ;........A Delete type ZPC segment
  . ;djb/bp Patch 210. Eliminate indirection[rel 204]
  . D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA)
@@ -65,6 +64,5 @@
  .. S ID=""
  .. F  S ID=$O(@POS@(DFN,PTPI,ID)) Q:ID=""  D  ;djb/bp BIG-1199-71271
- ... N SUB  ; og/sd/524
- ... S SUB=PTPI,DATA="^^^" ;........A Delete type ZPC segment
+ ... S DATA="^^^" ;........A Delete type ZPC segment
  ... ;djb/bp Patch 210. Eliminate indirection[rel 204]
  ... D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLS.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCHLS.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCHLS.m	(revision 636)
@@ -1,4 +1,4 @@
-SCMCHLS ;BPOI/DJB - PCMM HL7 Segment Utils;12/13/99
- ;;5.3;Scheduling;**177,210,212,293,515,524**;08/13/93;Build 29
+SCMCHLS ;BP/DJB - PCMM HL7 Segment Utils ; 12/13/99 12:40pm
+ ;;5.3;Scheduling;**177,210,212,293,515**;AUG 13, 1993;Build 14
  ;
  ;Ref rtn: SCDXMSG1
@@ -37,5 +37,5 @@
  ; PATCH 515 DLL USE ORIG TRIG 
  ; old code = M @XMITARRY@($P(ID,"-",1),"ZPC",ID)=VAFZPC
- M @XMITARRY@(SUB,"ZPC",ID)=VAFZPC  ; og/sd/524
+ M @XMITARRY@(NUM,"ZPC",ID)=VAFZPC
  Q
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCMU2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCMU2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCMU2.m	(revision 636)
@@ -1,4 +1,4 @@
-SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98
- ;;5.3;Scheduling;**148,177,524**;AUG 13, 1993;Build 29
+SCMCMU2 ;ALB/MJK - PCMM Mass Team/Position Unassignment Processing ; 10-JUL-1998
+ ;;5.3;Scheduling;**148,177**;AUG 13, 1993
  ;
 QUE() ; -- queue mass unassignment
@@ -169,6 +169,6 @@
  . ; -- if assignment date is in future then delete
  . IF SCASDT>DT,SCASDT>SCDATE D  Q
- . . N DA,DIE,DIK,DR
- . . S DA=SCIEN,(DIE,DIK)="^SCPT(404.43,",DR=".04///"_DT D ^DIE  ; og/sd/524
+ . . N DA,DIK
+ . . S DA=SCIEN,DIK="^SCPT(404.43,"
  . . D LOCK(SCNODE)
  . . D ^DIK
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCPT2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCPT2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCPT2.m	(revision 636)
@@ -1,3 +1,3 @@
-SCMCPT2 ; GENERATED FROM 'SCMC INCONSISTENT' PRINT TEMPLATE (#1448) ; 12/27/06 ; (FILE 404.57, MARGIN=132)
+SCMCPT2 ; GENERATED FROM 'SCMC INCONSISTENT' PRINT TEMPLATE (#1467) ; 12/25/06 ; (FILE 404.57, MARGIN=132)
  G BEGIN
 N W !
@@ -12,5 +12,5 @@
 BEGIN ;
  S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)
- I $D(DXS)<9 M DXS=^DIPT(1448,"DXS")
+ I $D(DXS)<9 M DXS=^DIPT(1467,"DXS")
  S I(0)="^SCTM(404.57,",J(0)=404.57
  W ?0 S X=$P($$GETPRTP^SCAPMCU2(D0,DT),U,2) W $E(X,1,8) K Y(404.57,304)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCPT6.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCPT6.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCPT6.m	(revision 636)
@@ -1,3 +1,3 @@
-SCMCPT6 ; GENERATED FROM 'SCMC DIRECT PC FTEE 1 CLN' PRINT TEMPLATE (#1452) ; 12/27/06 ; (FILE 404.52, MARGIN=132)
+SCMCPT6 ; GENERATED FROM 'SCMC DIRECT PC FTEE 1 CLN' PRINT TEMPLATE (#1471) ; 12/25/06 ; (FILE 404.52, MARGIN=132)
  G BEGIN
 CP G CP^DIO2
@@ -21,5 +21,5 @@
 BEGIN ;
  S:'$D(DN) DN=1 S DISTP=$G(DISTP),DILCT=$G(DILCT)
- I $D(DXS)<9 M DXS=^DIPT(1452,"DXS")
+ I $D(DXS)<9 M DXS=^DIPT(1471,"DXS")
  S I(0)="^SCTM(404.52,",J(0)=404.52
  S X=$G(^SCTM(404.52,D0,0)) W ?0 S Y=$P(X,U,3) S Y=$S(Y="":Y,$D(^VA(200,Y,0))#2:$P(^(0),U),1:Y) W $E(Y,1,15)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCQK1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCQK1.m	(revision 636)
@@ -1,4 +1,4 @@
-SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02
- ;;5.3;Scheduling;**148,177,231,264,436,297,446,524**;AUG 13, 1993;Build 29
+SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002  12:10 PM  ; Compiled April 12, 2007 10:03:59
+ ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77
  ;
  ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER
@@ -11,5 +11,5 @@
  G:SCDISCH<1 QTUNTP
  G:'$$CONFIRM() QTUNTP
- S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)  ; og/sd/524
+ S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER)
  G:OK'>0 QTUNTP
  S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCTSK1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK1.m	(revision 636)
@@ -1,12 +1,12 @@
-SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003  9:36 AM ; 10/24/07 12:24pm  ; Compiled January 25, 2008 12:11:43  ; Compiled March 26, 2008 22:27:26
- ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21
- Q
-INACTIVE ;
- ;Flag patients
- N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD S CNT=0
- D DT^DICRW
- N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q
- I SDDT'>0 D DT^DICRW S SDDT=DT
- S %DT="",X="T-11M" D ^%DT S STDD=+Y
+SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003  9:36 AM ; 10/24/07 12:24pm
+ ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
+ Q
+INACTIVE ;run every night to determine if patient can be inactivated from
+ ;team
+ ;Inactivation happens for patients without activity for 24 months
+ N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q S CNT=0
+ D DT^DICRW S %DT="",X="T-11M" D ^%DT S STDT=Y
+ S SC297=$$PDAT^SCMCGU("SD*5.3*297"),X1=DT,X2=SC297 D D^%DTC S SC297=X
+ S X="T-"_$S(SC297>330:"11M",1:"23M") D ^%DT S TYDT=+Y
  S A="^SCPT(404.43,""ADFN""",L=""""""
  S Q=A_")"
@@ -14,70 +14,56 @@
  .S ENTRY=+$P(Q,",",6)
  .S ZERO=$G(^SCPT(404.43,+ENTRY,0))
- .I $P(ZERO,U,15) Q
  .S POS=+$P(ZERO,U,2)
- .I $P(ZERO,U,4) Q  ;UNASS
- .I '$P(ZERO,U,5) Q  ;Not PC
- .I $P(ZERO,U,3)>STDD Q  ;<11 months
- .I $P(ZERO,U,17) Q  ;React
- .;get preceptor
+ .S TEAM=$P(Q,",",4)
+ .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q  ;no automatic for this team
+ .;I $G(^DPT(DFN,.35)) D DIS Q  ;Patient is deceased
+ .I $P(ZERO,U,3)>STDT Q  ;Later
+ .I $P(ZERO,U,17) Q  ;Already reactivated
+ .;get preceptor position
  .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
+ .;see if provider changed
+ .I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) Q
+ .I $P(ZERO,U,4) Q  ;Already unassigned
+ .I '$P(ZERO,U,5) Q  ;Not primary care
+ .;I $P(ZERO,U,16) Q  ;No Automatic unassign
+ .;Check if any activity
  .S DFN=$P(Q,",",3)
  .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN)
  .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U)
- .N STDT S %DT="",X="T-12M" D ^%DT S STDT=+Y
- .;N-new or E-est
- .N NEW
- .I $P(ZERO,U,3)<STDT S NEW=0
- .E  S NEW=1
- .N TYDT
- .I NEW N STDT S %DT="",X="T-11M" D ^%DT S STDT=+Y D
- ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- .I 'NEW N STDT S %DT="",X="T-23M" D ^%DT S STDT=+Y Q:$P(ZERO,U,3)'<STDT  D
- ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- .N PROV,SEEN,PRECP D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
- .;flag
- .S DIE="^SCPT(404.43,",DR=".15////"_SDDT,DA=ENTRY D ^DIE
- .S TPZ=$G(^SCTM(404.57,+POS,2))
- .I "TP"[$P(TPZ,U,9) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
- .I $P(TPZ,U,10),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
- Q
-SEEN(DFN,POS,TYDT,SDDT,PROV,PROVP,SEEN) ;
- S SEEN=0,PROVP=""
- N SCPRO,I,PRO,X,SCPRDTS,SCPR,PREC
- S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
- S SCPRDTS("BEGIN")=TYDT,SCPRDTS("END")=SDDT,SCPRDTS("INCL")=0
+ .D SEEN Q:SEEN
+ .I '$P(ZERO,U,15) D
+ ..S DIE="^SCPT(404.43,",DR=".15////"_DT,DA=ENTRY D ^DIE
+ ..S TPZ=$G(^SCTM(404.57,+POS,2))
+ ..I "TP"[$P(TPZ,U,10) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
+ ..I $P(TPZ,U,9),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
+ Q
+SEEN ;was patient seen
+ S SEEN=0
+ N SCPRO,I,PRECP,PRO
+ N X,SCPRDTS,SCPR
+ ;get list of providers for this position
+ S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)=""
+ S SCPRDTS("BEGIN")=TYDT
+ S SCPRDTS("END")=DT
  S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
- S I=0 F  S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))="",SCPRO(+SCPR(I),I)=$P(SCPR(I),U,9,10) D
- .S PREC=$P(SCPR(I),U,12)
- .I PREC,PREC'=POS S PROVP=+$$GETPRTP^SCAPMCU2(PREC,SDDT) S SCPRO(+PROVP)="" S SCPRO(+PROVP,I)=$P(SCPR(I),U,9,10)
+ F I=0:0 S I=$O(SCPR(I)) Q:'I  S SCPRO(+SCPR(I))=""
+ S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)=""
  F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I  D  Q:SEEN
- .S J=0 F  S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
+ .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J  D  Q:SEEN
  ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q
- ..S PRO=0 F  S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
- ...I $D(^SDD(409.44,"AO",J,$G(PRO))) D CHK I SEEN=1 Q
- ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) D CHK I SEEN=1 Q
- Q
-CHK ;
- N SDX S SDX="" F  S SDX=$O(SCPRO(PRO,SDX)) Q:SDX=""  D  Q:SEEN
- .I $P(SCPRO(PRO,SDX),U,2)="" D  Q
- ..I I'<$P(SCPRO(PRO,SDX),U) S SEEN=1
- .I I'<TYDT&(I'>$P(SCPRO(PRO,SDX),U,2)) S SEEN=1
- Q
-DIS ;disch
+ ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO  D  Q:SEEN
+ ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q  ;GET THE PROVIDERJ
+ ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V  I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q
+ Q
+DIS ;discharge
  N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0))
- I $P(ZERO,U,4) Q
+ I $P(ZERO,U,4) Q  ;Already discharged
  D DIS2^SCMCTSK7
  Q
-CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
- S DATA(0)=-1
- Q
-EXTEND(DATA,SCTEAM) ;to inact. in next 60 days
+EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days
  ;IEN^POSITION^PATIENT^EXTENDED^REASON
  K DATA,SCDATA,SDDATA
  N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="<DATA>"
- D DT^DICRW
- N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q
- I SDDT'>0 D DT^DICRW S SDDT=DT
- S X="T-9M" D ^%DT S STDT=Y
+ D DT^DICRW S X="T-9M" D ^%DT S STDT=Y
  S X="T-21M" D ^%DT S TYDT=+Y  ;MAKE THIS 21
  S POSA=""
@@ -91,7 +77,7 @@
  .S CNT=CNT+1
  Q
-POS I '$$DATES^SCAPMCU1(404.59,POS) Q  ;Position inact
+POS I '$$DATES^SCAPMCU1(404.59,POS) Q   ;Not an active position
  I '$P($G(^SCTM(404.57,POS,0)),U,4) Q  ;Not PC
- ;patients for position
+ ;get patients for this position
  K ^TMP("SC TMP LIST",$J)
  S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
@@ -101,5 +87,5 @@
  .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q
  .S DFN=+SCDATA
- .D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
+ .D SEEN Q:SEEN
  .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1
  K @SCLIST
@@ -107,5 +93,5 @@
 FILE(RES,DATA) ;File data on FTEE
  N I
- F I=1:1 Q:'$D(DATA(I))  D
+ F I=1:1 Q:'$D(DATA(I))   D
  .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]")
  .S ZERO=$G(^SCPT(404.43,+DATA(I),0))
@@ -116,5 +102,5 @@
  I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR")
  Q
-SCREEN ;Active assign. screen
+SCREEN ;Screen for active assignments
  N A S A=$G(^SCTM(404.52,D0,0))
  N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q
@@ -124,5 +110,5 @@
  I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
  S X=1 Q
-SUM(PR,POSI) ;get pos for prov
+SUM(PR,POSI) ; get positions for this provider
  N I,INS,ZERO,SCA,TEAM,FTEE,Z
  S I="",FTEE=0
@@ -139,16 +125,16 @@
  .S FTEE=FTEE+$P(ZERO,U,9)
  Q FTEE
-FTEECHK(DATA,PAIEN) ;check Ftee>1
+FTEECHK(DATA,PAIEN) ;check Ftee greater than 1
  N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A)
  S DATA=0
  S DATA=FTEE+$P(PAIEN,U,2)
  Q
-SORT(DIPA,SDD) ;sort tmpl
- N DIC
+SORT ;sort template
+ N DIC,DIPA
  S DIC=4,DIC(0)="ZME"
  S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
  S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR
- I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",SDD=1 Q
- D ^DIC I Y<0 S DIPA("SI")=X S SDD=X Q:SDD[U  D
+ I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",X=1 Q
+ D ^DIC I Y<0 S DIPA("SI")=X Q:X[U  D
  .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR
  .I X="LAST" S DIPA("EI")="zzz"
@@ -156,6 +142,6 @@
  D ^DIC
  I Y>0 S DIPA("EI")=$P(Y(0),U)
- I Y<0 S DIPA("EI")=X S SDD=X Q:SDD[U
- S SDD=1 Q
+ I Y<0 S DIPA("EI")=X Q:X[U
+ S X=1 Q
 FTEERPT ;FTEE REPORT
  D FTERPT^SCMCTSK6 Q
@@ -169,5 +155,5 @@
  S DATA=0
  I ('INFO)!('$P(INFO,U,2)) Q
- ;Is provider role acceptable?
+ ;Check if provider can be in this role.
  S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J=""
  I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J Q
@@ -191,22 +177,26 @@
  S SCDFN=+Y W !,SCDFN
 SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)"
- ;quit if no PC assign
+ ;
+ ;quit if no PC assignments
  Q:'$D(@SC1)
  S SCADT=0
  F  S SCADT=$O(@SC1@(SCADT)) Q:SCADT=""  D
- .S SCTP=0
- .F  S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP  D
- ..; quit if team position does not exist
- ..Q:'$D(^SCTM(404.57,SCTP,0))
- ..S SCPAI=0
- ..F  S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI  D
- ...S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
- ...;quit if not active within date range
- ...Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
- ...N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
- ...;add to HL7 event file
- ...Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
- ...Q:$$CHECK^SCMCHLB1(SCVAR)'=1
- ...D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
+ . S SCTP=0
+ . F  S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP  D
+ . . ;
+ . . ; quit if team position does not exist
+ . . Q:'$D(^SCTM(404.57,SCTP,0))
+ . . S SCPAI=0
+ . . F  S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI  D
+ . . . S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4)
+ . . . ;
+ . . . ; quit if not active within date range
+ . . . Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
+ . . . N SCVAR S SCVAR=SCPAI_";SCPT(404.43,"
+ . . . ;
+ . . . ; add to HL7 event file
+ . . . Q:$D(^SCPT(404.48,"AACXMIT",SCVAR))
+ . . . Q:$$CHECK^SCMCHLB1(SCVAR)'=1
+ . . . D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
  Q
 PRSEED ;seed practitioner
@@ -214,6 +204,7 @@
  S SC177=$$PDAT^SCMCGU("SD*5.3*177")
  I +SC177=0 D  Q
- . S SC2=" No SD*5.3*177 Installation Date."
+ . S SC2="  Unable to obtain SD*5.3*177 Installation Date."
  . D MSG^SCMCCV6(SC1,SC2)
+ . Q
  S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0
  S SCPROV=+Y
@@ -230,5 +221,5 @@
  . D ADD^SCMCHLE("NOW",SCVAR,,AH,1)
  Q
-INCON ;inconsistent PC assignments
+INCON ;get list of incositent provider assignments
  N POS
  D INCON^SCMCTSK3
@@ -240,4 +231,11 @@
  D EN1^DIP
  Q
+CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
+ S DATA(0)=-1
+ N I
+ N POS,DFN S DFN=+$G(INFO) Q:'DFN  S POS=+$P($G(INFO),U,2) Q:'POS
+ F I=0:0 S I=$O(^SCTM(404.57,POS,5,I)) Q:'I  D CECHK^SCRPPAT2(I,.CNAME,DFN) I $L(CNAME) S:DATA(0)=-1 DATA(0)="" S DATA(0)=DATA(0)_CNAME_"."
+ I DATA(0)'=-1 S DATA(0)=$E(DATA(0),1,$L(DATA(0))-2)
+ Q
 INACTDT(PA) ;Scheduled inactivation date.
  D INACT^SCMCTSK3 Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCTSK2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK2.m	(revision 636)
@@ -1,91 +1,85 @@
-SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003  9:36 AM ; 10/24/07 12:23pm  ; Compiled November 21, 2007 13:32:47  ; Compiled March 17, 2008 15:27:15
- ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21
- Q
-NIGHT ;
- N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT
- D DT^DICRW S SDDT=$P($G(^XTMP("SCMCTSK2-"_DT,0)),U,2)
- I SDDT="" S SDDT=DT
- S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<SDDT S ALPHA=0
- ;if 'ALPHA NOINAC=1 except 15th and the Last Day of a Month (LDoM)
- ;inact only on 15th and on LDoM
- S NOINAC=0
- I 'ALPHA  S X1=SDDT,X2=1 D C^%DTC I ($E(SDDT,6,7)'=15)&($E(SDDT,1,5)=$E(X,1,5)) S NOINAC=1
- I 'ALPHA D INACTIVE^SCMCTSK1
+SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003  9:36 AM ; 10/24/07 12:23pm
+ ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6
+ Q
+NIGHT ;nightly task for inact.
+ N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN
+ K ^TMP("SCTSK",$J)
+ D DT^DICRW
+ S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA<DT S ALPHA=0
+ ;check if this is last day of month
+ S X1=DT,X2=1 D C^%DTC I $E(DT,1,5)'=$E(X,1,5) I 'ALPHA D INACTIVE^SCMCTSK1
  S SIXM=$P($G(^SCTM(404.44,1,1)),U,9)
  I SIXM D PRFLAG
  I ALPHA D INACTIVE^SCMCTSK1
- ;determine ENDDT-Inactn Date-30 days if flagged today
- F DATE=0:0 S DATE=$O(^SCPT(404.43,"AFLG",DATE)) Q:'DATE  D
+ S NOINAC=0 I 'ALPHA  S X1=DT,X2=1 D C^%DTC I ($E(DT,6,7)'=15)&($E(DT,1,5)=$E(X,1,5)) S NOINAC=1
+ ;check for 60 days after flagged for inact.
+ S X1=DT,X2=$S(ALPHA:-2,1:-30) D C^%DTC S ENDDT=X
+ F DATE=0:0 S DATE=$O(^SCPT(404.43,"AFLG",DATE)) Q:(('DATE)!(('NOINAC)&(DATE>ENDDT)))  D
  .F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY  D
  ..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO
  ..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN
  ..S POS=$P(ZERO,U,2)
- ..I $P(ZERO,U,4) D UNFLG Q  ;unass.
- ..S X1=DATE,X2=$S(ALPHA:+2,1:+30) D C^%DTC S ENDDT=X
- ..N SDASS S SDASS=$P(ZERO,U,3)
- ..;N-new or E-stbl.
- ..;assig >12 months since flagging, not NEW, E-stbl)
- ..N NEW
- ..S NEW=0 S X1=DATE,X2=SDASS D ^%DTC I X<365 S NEW=1
- ..I NEW S %DT="",X="T-12M" D ^%DT S STDT=+Y D
- ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- ..I 'NEW S %DT="",X="T-24M" D ^%DT S STDT=+Y D
- ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- ..;
- ..I $P(ZERO,U,17) D UNFLG Q  ;react.
- ..;get prec 
- ..;S %DT="",X="T-12M" D ^%DT S STDT=+Y
- ..;S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
- ..I '$P(ZERO,U,5) D UNFLG Q  ;Not PC
- ..D SEEN^SCMCTSK1(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)
- ..;S PC=$$GET^XUA4A72(+PROV)
- ..I SEEN D UNFLG Q
- ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>SDDT Q  ;do not inactivate yet; extended
- ..I ('NOINAC)&(SDDT'<ENDDT) D DIS^SCMCTSK1
- ;flag prov 6m after install sd/297
- I NOINAC D:ALPHA BULL I '$D(^SCPT(404.43,"AFLG",SDDT)) K ^TMP($J,"SCMCTSK2") Q
- ;flag prov 6m after install sd/297
- I SIXM,SIXM'>SDDT D
+ ..I $P(ZERO,U,4) D UNFLG Q  ;already unassigned
+ ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>DT Q    ;ext
+ ..;check if criteria still met
+ ..I $P(ZERO,U,17) D UNFLG Q  ;Already reactivated
+ ..;get preceptor position
+ ..S %DT="",X="T-12M" D ^%DT S STDT=+Y
+ ..S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS)
+ ..;see if provider changed
+ ..I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) D UNFLG Q
+ ..I '$P(ZERO,U,5) D UNFLG Q  ;Not primary care
+ ..S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
+ ..S PC=$$GET^XUA4A72(+PROV)
+ ..S SC297=$$PDAT^SCMCGU("SD*5.3*297")
+ ..N NEW S NEW=$S($P(ZERO,U,3)<SC297:0,1:1)   ;D D^%DTC S NEW=$S(X>330:0,1:1)
+ ..S X1=DT,X2=SC297 D D^%DTC S SC297=X
+ ..S X="T-"_$S(SC297>365:"11M",NEW:"11M",1:"23M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D UNFLG Q 
+ ..S X="T-"_$S(SC297>365:"12M",NEW:"12M",1:"24M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D:(DATE>ENDDT) UNFLG Q
+ ..I ('NOINAC)&(DATE'>ENDDT) D DIS^SCMCTSK1
+ ..;D MSG(POS,DFN)
+ ;if 6 months after installation check to flag providers
+ I NOINAC D:ALPHA BULL Q
+ S PATDT=$$PDAT^SCMCGU("SD*5.3*297") Q:'PATDT
+ I SIXM,SIXM'>DT D
  .D PRINAC
  .N FLDA
  .S FLDA(404.44,"1,",19)=""
  .D FILE^DIE("I","FLDA","ERR")
- D BULL K ^TMP($J,"SCMCTSK2")
- Q
-UNFLG ;Unflagging
+ D BULL
+ Q
+UNFLG ;Remove the flag
  N DR,DIE,DA
  S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE
  Q
-PRFLAG ;flag incorrect provider pos
+PRFLAG ;flag incorrect provider positions
  N POS
- ;prov inact. has run once
+ ;provider inactivation has run once
  I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q
  D PRFLAG^SCMCTSK3
  Q
-PRINAC ;inact. flagged providers
+PRINAC ;inactivate flagged providers
  N I,II
- ;Prov inact. run already
- I $G(SDDT)="" S SDDT=DT
- S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=SDDT Q
+ ;Provider inactivation run already
+ S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=DT Q
  F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I  S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D
  .;I $P(ZERO,U,10)>$G(ENDT) Q   ;not time yet
- .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q   ;inactivated
- .;Check valid criteria
+ .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q   ;already inactivated
+ .;Check if criteria still valid
  .S POS=+ZERO
- .S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
+ .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT)
  .S PC=$$GET^XUA4A72(+PROV)
  .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE  ;remove flag
  .S ZERO1=$G(^SCTM(404.57,POS,0))
  .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D
- ..;inactivation
- ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
+ ..;enter the inactivation
+ ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_DT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1"
  ..S DIC(0)="LM" D ^DIC
- ;only run inact. once
- S $P(^SCTM(404.44,1,1),U,11)=SDDT
- Q
-FUTAPP(DFN) ;print future appts
+ ;only run the inactivation once.
+ S $P(^SCTM(404.44,1,1),U,11)=DT
+ Q
+FUTAPP(DFN) ;print future appointments
  N TAB,SCDT0 S TAB=$X
- I $G(SDDT)="" S SDDT=DT
- S SCDT=SDDT+.24
+ S SCDT=DT+.24
  F  S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT  D
  . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2))
@@ -93,29 +87,28 @@
  . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10)
  Q
-GETASC(DATA,ENTRY) ;get assoc. clinics
+GETASC(DATA,ENTRY) ;get associated clinics
  N I,CNT S CNT=0
  F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I  S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U)
  Q
-SETASC(RESULT,DATA) ;set assoc. clinics
+SETASC(RESULT,DATA) ;set associated clinics
  D SETASC^SCMCTSK7(.RESULT,DATA) Q
-MSG(SCTP,DFN) ;send inact. message
- ;given valid positions get current practitioners
+MSG(SCTP,DFN) ;send inactivation message
+         ;given list of valid positions get current practitioners
  S SCLIST="SCL"
- I $G(SDDT)="" S SDDT=DT
  I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D
  .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR)
  .;if preceptor notice turned on for message type
  I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D
- .S SCX=+$$OKPREC2^SCMCLK(SCTP,SDDT)
+ .S SCX=+$$OKPREC2^SCMCLK(SCTP,DT)
  .;if preceptor duz returned, add to array
  .I SCX S @SCLIST@("SCPR",SCX)=""
  N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I  S XMY(I)=""
- S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from PC team position "_$P($G(^SCTM(404.57,SCTP,0)),U)
+ S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from primary care team position "_$P($G(^SCTM(404.57,SCTP,0)),U)
  S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD
  Q
-BULL ;EOM Bulletin
+BULL ;end of Month Bulletin
  N DISUPNO,BY,DHIT,HEAD
  S DISUPNO=1,L=0
- S XMSUB="Patients Scheduled for Inactivation from PC Panel"
+ S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel"
  S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
  K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J)
@@ -130,9 +123,9 @@
  .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J)
  .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI)
- .S XMSUB="Patients Scheduled for Inactivation from PC Panel"
+ .S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel"
  .S XMTEXT="^TMP(""SCMCTXT"",$J,"
+ .;D LINES(1) D ^XMD
  S DISUPNO=1
  K ^TMP("SCMC",$J),^TMP("SCMCTXT")
- I $G(NOINAC) K ^TMP($J,"SCMCTSK2") Q  ; SD/499
  S XMSUB="Patients With Extended PCMM Inactivation Dates"
  S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
@@ -147,5 +140,5 @@
  S DISUPNO=1
  K ^TMP("SCMC",$J),^TMP("SCMCTXT")
- S XMSUB="Patients Automated Inactivations from PC Panels"
+ S XMSUB="Patients Automated Inactivations from Primary Care Panels"
  S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
  K ^TMP("SCMC",$J)
@@ -160,5 +153,5 @@
  K ^TMP("SCMC",$J),^TMP("SCMCTXT")
  I $P($G(^SCTM(404.44,1,1)),U,11)="" D
- . S XMSUB="PC Providers Scheduled for Inactivation"
+ . S XMSUB="Primary Care Providers Scheduled for Inactivation"
  . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")=""
  . K ^TMP("SCMC",$J)
@@ -189,5 +182,5 @@
 INRPT  ; REPORT
  N DIOEND,SCDHD
- D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS")
+ D PROMPT^SCMCTSK3("**** Date Range Selection ****","DATE PATIENTS INACTIVATED FROM PRIMARY CARE PANELS")
  Q:'$D(^TMP("SC",$J,"XR"))
  D UNASSIGN^SCMCTSK3
@@ -201,6 +194,6 @@
  D EN1^DIP
  Q
-IN30 ;inact. last month
- N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD  ;SD/499
+IN30 ;inactivated last month
+ D SORT^SCMCTSK1 Q:'X
  S Q=""""
  S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]"
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK3.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK3.m	(revision 636)
@@ -1,4 +1,4 @@
-SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am  ; Compiled June 7, 2007 13:57:55  ; Compiled February 12, 2008 11:46:47
- ;;5.3;Scheduling;**297,499**;AUG 13, 1993;Build 21
+SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am
+ ;;5.3;Scheduling;**297**;AUG 13, 1993
  Q
 SORTP  ;sort template
@@ -78,5 +78,5 @@
  .D SUBT^SCRPW50(DATESORT)
  .S SCBDT("B")="T-30",SCEDT("B")="TODAY"
- .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+60"
+ .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+30"
  S LIST="DIV,TEAM,POS,ASPR"
  ;D SUBT^SCRPW50("**** Date Range Selection ****")
@@ -210,12 +210,7 @@
  .I '$D(^SD(403.46,+$P(ZERO,U,3),2,+PC)) S ^TMP("SCMCTSK",$J,POSH)="Person Class is not valid for this role"
  F POS=0:0 S POS=$O(^TMP("SCMCTSK",$J,POS)) Q:'POS  S FLDA(404.52,POS_",",.091)=DT
-VERPR ;verify already flagged positions; SD/499 replaced "AFLG" with "AFLAG"
- N II,POSH S II="" F  S II=$O(^SCTM(404.52,"AFLAG",II)) Q:'II  S POSH=""  F  S POSH=$O(^SCTM(404.52,"AFLAG",II,POSH)) Q:'POSH  D
- .N ZERO,ZEROTP S ZERO=$G(^SCTM(404.52,POSH,0))
+ F I=0:0 S I=$O(^SCTM(404.52,"AFLG",I)) Q:'I  F POSH=0:0 S POSH=$O(^SCTM(404.52,"AFLG",I,POSH)) Q:'POSH  D
+ .N ZERO S ZERO=$G(^SCTM(404.52,POSH,0))
  .I '$P(ZERO,U,4) S FLDA(404.52,POSH_",",.091)="" Q
- .;SD/499; added verification of the POSSIBLE PRIMARY PRACTITIONER field
- .;in the TEAM POSITION file
- .N TP S TP=$P(ZERO,U) S ZEROTP=$G(^SCTM(404.57,TP,0))
- .I '$P(ZEROTP,U,4) S FLDA(404.52,POSH_",",.091)="" Q
  .I (-$O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999)))>$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)=""
  I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR")
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK4.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCTSK4.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK4.m	(revision 636)
@@ -1,4 +1,4 @@
 SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003  9:36 AM
- ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8
+ ;;5.3;Scheduling;**297**;AUG 13, 1993
  Q
 POSCHK ;
@@ -30,5 +30,5 @@
  W !,"   Field Name              Explanation of field name"
  W !,"   Patient Name            Name of patient scheduled to be inactivated from their primary care team and position/provider"
- W !,"   SSN                     Patient SSN."
+ W !,"   SSN                     Patient's last 4 Social Security numbers."
  W !,"   PC Team                 Patient's assigned Primary Care team in PCMM."
  W !,"   Provider                Name of primary care practitioner/provider currently assigned to the patient.  This will be an"
@@ -56,5 +56,5 @@
  W !,"  Field Name              Explanation of field name"
  W !,"  Patient Name            Name of patient scheduled to be inactivated from their primary care team and position/provider."
- W !,"  SSN                     Patient SSN."
+ W !,"  SSN                     Patient's last 4 SSN numbers."
  W !,"  Institution             Institution name, previously called Division, in which patient receives primary care."
  W !,"  PC Team                 Patient's assigned Primary Care team in PCMM."
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK9.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCTSK9.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCTSK9.m	(revision 636)
@@ -1,4 +1,4 @@
 SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003  9:36 AM
- ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8
+ ;;5.3;Scheduling;**297**;AUG 13, 1993
  Q
 EXTKEY ;
@@ -10,5 +10,5 @@
  W !
  W !,"Patient Name          Name of patient scheduled to be inactivated from their primary care team and position/provider."
- W !,"SSN                   SSN number."
+ W !,"SSN                   Patient's last 4 SSN numbers."
  W !,"Institution           Institution name, previously called Division, in which patient receives primary care."
  W !,"PC Team               The patient's assigned Primary Care team in PCMM."
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCYPC.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMCYPC.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMCYPC.m	(revision 636)
@@ -1,3 +1,3 @@
-SCMCYPC ; GENERATED FROM 'SCMC DIRECT PC FTEE' PRINT TEMPLATE (#1320) ; 12/27/06 ; (FILE 404.52, MARGIN=132)
+SCMCYPC ; GENERATED FROM 'SCMC DIRECT PC FTEE' PRINT TEMPLATE (#1320) ; 12/25/06 ; (FILE 404.52, MARGIN=132)
  G BEGIN
 CP G CP^DIO2
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMSVUT2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCMSVUT2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCMSVUT2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99
- ;;5.3;Scheduling;**66,180,254,293,325,466,521**;AUG 13,1993;Build 1
+ ;;5.3;Scheduling;**66,180,254,293,325,466**;AUG 13,1993;Build 2
  ;06/28/99 ACS Added CPT modifier validation
  ;
@@ -195,8 +195,8 @@
  I STDT="" Q 0
  S STDT=$$FMDATE^HLFNC(STDT)
- S X=STDT,%DT="X" D ^%DT I Y=-1 Q 0  ;SD/521 added %DT
+ S X=STDT D ^%DT I Y=-1 Q 0
  I ENDT="" Q 1
  S ENDT=$$FMDATE^HLFNC(ENDT)
- S X=ENDT,%DT="X" D ^%DT I Y=-1 Q 0  ;SD/521 added %DT
+ S X=ENDT D ^%DT I Y=-1 Q 0
  I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0
  Q 1
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPBK11.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPBK11.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPBK11.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
- ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41**;AUG 13, 1993
  ;
 GETSEL(SCDATA,SCTYPE,SCIEN) ; 
@@ -83,7 +83,7 @@
  D SET("    Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA)
  D SET(" ",.SCINC,.SCDATA)
- D SET("Associated Teams and Positions:",.SCINC,.SCDATA)
+ D SET("Assoicated Teams and Positions:",.SCINC,.SCDATA)
  D SET("-------------------------------",.SCINC,.SCDATA)
- S SCI=0 F  S SCI=$O(^SCTM(404.57,"E",SCID,SCI)) Q:'SCI  D
+ S SCI=0 F  S SCI=$O(^SCTM(404.57,"D",SCID,SCI)) Q:'SCI  D
  . S X=$G(^SCTM(404.57,SCI,0))
  . D SET("      Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPEC.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPEC.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPEC.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,140,174,177,431,526,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,140,174,177,431**;AUG 13, 1993
  ;
  ;Detailed Listing of Patients and Their Enrolled Clinics Report
@@ -80,8 +80,8 @@
  Q
  ;
-PDATA(DFN,CLNEN,CNAME,FLAG) ;
+PDATA(DFN,CLNEN,FLAG) ;
  ;Collect and format data for report
  ;
- N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT
+ N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT,CEN,CNAME
  S DATA=""
  S NODE=$G(^DPT(DFN,0))
@@ -90,11 +90,15 @@
  S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4)  ;means test status SD*5.3*431
  S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility
- S PSTAT="N/A"
- S STATD=""
- S LAST=$$GETLAST^SCRPU3(DFN,.CLNEN) ;last Clinic appointment
- S NEXT=$$GETNEXT^SCRPU3(DFN,.CLNEN) ;next clinic appointment
- ;I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(PTIEN,INS,TIEN,PDATA,CNAME,CIEN)
- I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,12)_"^"_DATA
- I $D(FLAG) S DATA=$E(NAME,1,12)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT
+ ;
+ S CNAME=$P($G(^SC(CLNEN,0)),"^")
+ S CEN=+$O(^DPT(DFN,"DE","B",CLNEN,""))
+ S NODE=$G(^DPT(DFN,"DE",CEN,1,1,0))
+ S PSTAT=$P(NODE,"^",2) S PSTAT=PSTAT_$S(PSTAT="A":"C",PSTAT="O":"PT",1:"") ;opt or ac status
+ I $P(NODE,"^")="" S STATD=""
+ I $P(NODE,"^")'="" S STATD=$TR($$FMTE^XLFDT($P(NODE,"^"),"5DF")," ","0") ;enrollment date
+ S LAST=$$GETLAST^SCRPU3(DFN,CLNEN) ;last clinic appointment
+ S NEXT=$$GETNEXT^SCRPU3(DFN,CLNEN) ;next clinic appointment
+ I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,20)_"^"_DATA
+ I $D(FLAG) S DATA=$E(NAME,1,20)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT
  Q DATA
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPEC2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPEC2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPEC2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,140,174,177,526**;AUG 13, 1993;Build 8
+ ;;5.3;Scheduling;**41,140,174,177**;AUG 13, 1993
  ;
  ;Detailed Listing of Patients and Their Enrolled Clinics Report
@@ -106,5 +106,5 @@
  S HLD="H1"
  S @STORE@("SUBHEADER",HLD)="Patient Name"
- S $E(@STORE@("SUBHEADER",HLD),16)="Pt ID"
+ S $E(@STORE@("SUBHEADER",HLD),18)="Pt ID"
  S $E(@STORE@("SUBHEADER",HLD),25)="Stat"
  S $E(@STORE@("SUBHEADER",HLD),31)="Elig"
@@ -129,7 +129,7 @@
  ;CIEN - clinic ien
  ;
- S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,12) ;patient name
- S $E(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$P(PDATA,"^",2) ;primary long id 9 digit
- S $E(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$P(PDATA,"^",3) ;means test category
+ S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,15) ;patient name
+ S $E(@STORE@(INS,TIEN,CIEN,PTIEN),18)=$E($P(PDATA,"^",2),6,10) ;primary long id last 4 plus P
+ S $E(@STORE@(INS,TIEN,CIEN,PTIEN),25)=$P(PDATA,"^",3) ;means test category
  S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility
  ;Removed by patch 174
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPITP.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993
  ;
  ;Individual Team Profile
@@ -105,5 +105,5 @@
  ;
 PRINTIT(STORE,TITL) ;
- N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL
+ N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF
  S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF
  D FORHEAD^SCRPITP2
@@ -136,14 +136,9 @@
  ..I $Y<IOSL-10 D COLUMN^SCRPITP2
  ..F  S POS=$O(@STORE@(INST,TIEN,"P",POS)) Q:POS=""!(STOP)  D
+ ...I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
+ ...I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
+ ...I STOP Q
  ...W !,$G(@STORE@(INST,TIEN,"P",POS))
- ...S ACL=""
- ...F  S ACL=$O(@STORE@(INST,TIEN,"P",POS,ACL)) Q:ACL=""!(STOP)  D
- ....W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
- ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
- ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP  D CONT^SCRPITP2
- ....I STOP Q
- ...;W !,$G(@STORE@(INST,TIEN,"P",POS))
- ...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL))
- ...W !
+ ..W !
  I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR
  Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPITP2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPITP2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99  18:24
- ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,177**;AUG 13, 1993
  ;
  ;Individual Team Profile
@@ -16,5 +16,5 @@
  S POS=$P(TNODE,"^") ;position name
  S ROL=$P($G(^SD(403.46,+$P(TNODE,"^",3),0)),"^") ;standard position
- S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>0:" AP",1:"PCP") ;primary care position
+ S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>1:" AP",1:"PCP") ;primary care position
  S MAX=$P(TNODE,"^",8)
  ;
@@ -24,17 +24,10 @@
  S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0)
  ;
- ;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS)
+ S CIEN=+$P(TNODE,"^",9) ;clinic ien
+ S PCLIN=""
+ I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic
  ;
- D SETASCL^SCRPRAC2(TPOS,.CNAME,.CLIEN)
- S CNAME=$G(CNAME(0))
- ;S CIEN=+$P(TNODE,"^",9) ;clinic ien ;USING MULTIPLE WITH SD*5.3*520
- ;S PCLIN=""
- ;I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic
+ D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,PCLIN,SCPROV,SCPTASS)
  ;
- D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS)
- N AC
- S AC=0
- F  S AC=$O(CNAME(AC)) Q:AC=""  D FORMATAC(POS,DIV,TM,TPOS,CNAME(AC))
- K CNAME
  Q
  ;
@@ -101,9 +94,5 @@
  S $E(@STORE@(DIV,TM,"P",POS),82)=$J(MAX,6,0) ;number of patients allowed
  S $E(@STORE@(DIV,TM,"P",POS),92)=$J(SCPTASS,6,0) ;patients assigned
- S $E(@STORE@(DIV,TM,"P",POS),103)=$E(CNAME,1,30)
- Q
- ;
-FORMATAC(POS,DIV,TM,TPOS,CNAME) ;clinic name
- S $E(@STORE@(DIV,TM,"P",POS,AC),103)=$E(CNAME,1,30)
+ S $E(@STORE@(DIV,TM,"P",POS),103)=$E(CNAME,1,30) ;clinic name
  Q
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPPAT2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPPAT2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPPAT2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPPAT2 ;ALB/CMM - Practitioner's Patients ; 12/12/00 3:46pm
- ;;5.3;Scheduling;**41,48,174,181,177,231,433,297,526,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,48,174,181,177,231,433,297**;AUG 13, 1993
  ;
  ;Listing of Practitioner's Patients
@@ -26,6 +26,6 @@
  ;ARY - array of patients for selected practitioner
  ;PRAC - practitioner ien
- N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,PTA,PTAN,TIEN
- N PC,TNODE,TNAME,PINF,POSN,PRCP,CNAME
+ N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,CNAME,PTA,PTAN,TIEN
+ N PC,TNODE,TNAME,PINF,POSN,PRCP
  S NXT=0
  F  S NXT=$O(@ARY@(NXT)) Q:NXT=""!(NXT'?.N)  D
@@ -49,31 +49,18 @@
  .I $G(ROLE)'=1,'$D(ROLE(+$P(TPN,U,3))) Q  ;not a selected role
  .S POSN=$P(TPN,"^") ;position name
- .D SETASCL^SCRPRAC2(TPI,.CNAME,.CLIEN)  ;get clinics from multiple
- .;S CLIEN=+$P(TPN,"^",9) ;associated clinic ien
+ .S CLIEN=+$P(TPN,"^",9) ;associated clinic ien
  .;commented next line off - clinic enrollment no longer needed SD*5.3*433
  .;D CECHK(CLIEN,.CNAME,PIEN) ;is patient enrolled in associated clinic?
- .;S CNAME=$P($G(^SC(CLIEN,0)),"^")  ; SD*5.3*433 remove enroll check
+ .S CNAME=$P($G(^SC(CLIEN,0)),"^")  ; SD*5.3*433 remove enroll check
  .S PC=$S($P(PTP,"^",5)=0:0,1:1) ;primary care position 1or2-yes/0-no
  .S PNAME=$P($G(^VA(200,+PRAC,0)),"^") ;practitioner name
  .Q:PNAME=""
  .S PRCP=$P($$OKPREC2^SCMCLK(TPI,DT),U,2)
- .D GETPINF(PIEN,.CLIEN,.PINF)  ;get patient information and appointments
- .S CNAME=$G(CNAME(0))  ;first line will capture position information
- .S PINF=$G(PINF(0))
- .I PINF=""  D 
- ..S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
- .D FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
- .D SETFORM(PIEN,.CNAME,.PINF)
-SETFORM(PIEN,CNAME,PINF)  ;Format for clinic info only for multiples
- N SCCNT
- S SCCNT=0 F  S SCCNT=$O(PINF(SCCNT)) Q:SCCNT=""  D FORMATAC(CNAME(SCCNT),PINF(SCCNT),PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
- Q
-GETPINF(PIEN,CLIEN,PINF)  ;get patient info 
- N SCCNT
- S SCCNT="" F  S SCCNT=$O(CLIEN(SCCNT)) Q:SCCNT=""  D 
- .S PINF(SCCNT)=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CLIEN(SCCNT),CNAME(SCCNT),1)
+ .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CLIEN,1)
+ .;$$PDATA returns pt name,pid,mt,pelig,status,status date,last appt,nxt appt
+ .D FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;formats data for display
  Q
  ;
-CECHK(CLIEN,CNAME,PIEN) ;should no longer be used as of patch SD*5.3*433
+CECHK(CLIEN,CNAME,PIEN) ;
  ;CLIEN - clinic ien
  ;CNAME - clinic name returned if patient is enrolled in clien clinic
@@ -112,26 +99,5 @@
  Q
  ;
-FORMATAC(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display
- ;CNAME - clinic name
- ;PINF - patient/clinic data
- ;PC - primary care 1/0
- ;TIEN - team file ien (#404.51)
- ;TNAME - team name
- ;PRAC - practitioner ien (#200)
- ;PNAME - practitioner name
- ;POSN - position name
- ;TPI - team position ien (#404.57)
- ;PRCP - preceptor name
- ;
- N IIEN,INAME,ERR
- S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP)
- I ERR Q
- ;
- I SORT=1 D STORA(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,team,practitioner
- I SORT=2 D STORA(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,practitioner,team
- I SORT=3 D STORA(1,PRAC,1,PINF,PNAME,"T3",TPI,SCCNT)
- Q
- ;
-STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ;
+STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI) ;
  ;IIEN - ien institution
  ;SEC - second sort subscript, IEN team or IEN practitioner
@@ -144,7 +110,8 @@
  N PIEN,PTNAME,PID
  S PIEN=+$P(PINF,"^") ;patient ien 
- S PTNAME=$E($P(PINF,"^",2),1,10) ;patient name
+ S PTNAME=$E($P(PINF,"^",2),1,15) ;patient name
  Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN))
  S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)=""
+ ;
  I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D
  .;count each unique patient for any given practitioner for grand total
@@ -157,5 +124,5 @@
  S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME
  S PID=$P(PINF,"^",3),PID=$TR(PID,"-","")
- S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),13)=PID ;ssn
+ S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),18)=$E(PID,6,10) ;last 4 pid - 5 places is for any pseudo
  S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status
  S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility
@@ -166,9 +133,2 @@
  S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic
  Q
-STORA(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ;
- I '$D(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT))  D
- .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),42)=$P(PINF,"^",8) ;last appt
- .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),54)=$P(PINF,"^",9) ;nxt appt
- .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),66)=$E(CNAME,1,15) ;clinic
- .Q
- Q 
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPPAT3.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPPAT3.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPPAT3.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm
- ;;5.3;Scheduling;**41,52,148,174,181,177,297,526,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,52,148,174,181,177,297**;AUG 13, 1993
  ;
  ;Listing of Practitioner's Patients
@@ -12,16 +12,9 @@
  .S PT=0
  .F  S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP)  D
+ ..I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER
+ ..I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER
+ ..Q:STOP
  ..I FIRST D HEADER S FIRST=0
  ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line
- ..;I FIRST D HEADER S FIRST=0
- ..N SCCN
- ..S SCCN=""
- ..F  S SCCN=$O(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) Q:SCCN=""  D
- ...W !,$G(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) ;print patient detail line
- ...I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER
- ...I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER
- ...Q:STOP
- ...;I FIRST D HEADER S FIRST=0
- ...Q
  ..Q
  .Q
@@ -74,5 +67,5 @@
 SHEAD ;
  S @STORE@("H2")="Pt Name"
- S $E(@STORE@("H2"),15)="Pt ID"
+ S $E(@STORE@("H2"),18)="Pt ID"
  S $E(@STORE@("H1"),25)="M.T."
  S $E(@STORE@("H2"),25)="Stat"
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPRAC2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPRAC2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPRAC2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,177**;AUG 13, 1993
  ;
  ;Practitioner Demographics Report
@@ -40,6 +40,5 @@
  .S MAX=$P(NODE,"^",8) ;max patient assignments to position
  .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients
- .N CNAME,SCCLIEN
- .D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics
+ .S CNAME=$P($G(^SC(+$P(NODE,U,9),0)),U) ;associated clinic
  .;
  .;Get preceptor
@@ -57,6 +56,6 @@
  .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN)
  .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP)
- .D SET3(4,"Assoc. Clinic: ")
- .D SETCNAME(.CNAME)
+ .D SET3(4,"Assoc.")
+ .D SET3(4,"Clinic: "_CNAME)
  .I $L(PCLASS(1)) D
  ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D
@@ -83,10 +82,4 @@
  Q
  ;
-SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS
- N I,CNT1
- S CNT1=0,I=0
- F  S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I  D
- .S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1
- Q
 SET1(LABEL,VALUE) ;Set output line
  S SCLN=SCLN+1
@@ -109,11 +102,6 @@
  Q
  ;
-SETCNAME(CNAME) ;associated clinics 
- N A
- S A="" F  S A=$O(CNAME(A)) Q:A=""  D SET3(12,CNAME(A))
- Q
- ;
 PINFO(VAE,PRACT,OPH,ROOM,SERV) ;
- ;practitioner information from new person file
+ ;practitioner information form new person file
  S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name
  S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPSLT.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPSLT.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPSLT.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,52,177,231,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,52,177,231**;AUG 13, 1993
  ;
  ;Summary Listing of Teams Report
@@ -105,5 +105,5 @@
  ;
 PRINTIT(STORE,TITL) ;
- N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC
+ N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS
  S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF
  D TITLE^SCRPU3(.PAGE,TITL)
@@ -130,12 +130,8 @@
  ...S POS=""
  ...F  S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP)  D
- ....W !,$G(@STORE@(INST,TEM,PRACT,POS))
- ....S SCAC=""
- ....F  S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,SCAC)) Q:SCAC=""!(STOP)  D
- .....W !,$G(@STORE@(INST,TEM,PRACT,POS,SCAC))
- .....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
- .....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
- .....I STOP Q
- ....;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
+ ....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE)
+ ....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM)
+ ....I STOP Q
+ ....W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info
  ..Q:STOP
  ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPSLT2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPSLT2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am
- ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,174,177,231**;AUG 13, 1993
  ;
  ;Summary Listing of Teams Report
@@ -23,8 +23,6 @@
  S POS=$P(TNODE,"^") ;position name
  ;SD*5.3*231 - call SCMCLK to determine in AP or not
- S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC?
- ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
- D SETASCL^SCRPRAC2(APOS,.PCLIN)
- S PCLIN=$G(PCLIN(0))
+ S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>1:" AP",1:"PCP") ;PC?
+ S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic
  S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name
  ;
@@ -57,7 +55,4 @@
  ;
  D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT)
- N SCAC
- S SCAC=0
- F  S SCAC=$O(PCLIN(SCAC)) Q:SCAC=""  D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM)
  Q
  ;
@@ -99,7 +94,4 @@
  S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC
  ;New code ends
- Q
-FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples
- S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30)
  Q
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTA.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTA.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTA.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,48,52,114,174,181,177,526**;AUG 13, 1993;Build 8
+ ;;5.3;Scheduling;**41,48,52,114,174,181,177**;AUG 13, 1993
  ;
  ;Patient Listing w/Team Assignment Data Report
@@ -149,5 +149,5 @@
  ;setup column headers
  S @STORE@("H2")="Patient Name"
- S $E(@STORE@("H2"),19)="Pt ID"
+ S $E(@STORE@("H2"),24)="Pt ID"
  S $E(@STORE@("H1"),31)="Date"
  S $E(@STORE@("H2"),31)="Assigned"
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTA2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTA2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99  1:33 PM
- ;;5.3;Scheduling;**41,88,140,148,174,181,177,526**;AUG 13, 1993;Build 8
+ ;;5.3;Scheduling;**41,88,140,148,174,181,177**;AUG 13, 1993
  ;
  ;Patient Listing w/Team Assignment Data Report continued
@@ -70,6 +70,5 @@
  S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name
  S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
- ;9 digit ssn SD*5.3*526 - dmr
- ;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
+ S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation
  ;
  S ADATE=$P(NODE,"^",3) ;position assignment date - fm format
@@ -119,6 +118,6 @@
  S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO")
  ;
- S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,17)
- S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),19)=PID
+ S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,21)
+ S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID
  S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE
  S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP
@@ -140,5 +139,5 @@
  S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name
  S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","")
- ;S PID=$E(PID,6,10) ;9 digit ssn patch 526
+ S PID=$E(PID,6,10) ;last 4 plus 5th for psuedo
  ;
  S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTM.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993
  ;
  ;List of Team's Members Report
@@ -154,5 +154,5 @@
 PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ;
  ;
- N CNT,SCAC
+ N CNT
  S CNT=""
  I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD)
@@ -161,6 +161,3 @@
  F  S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP)  D
  .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT))
- .S SCAC="" I CNT=4  D
- ..F  S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP)  D
- ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC))
  Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTM2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTM2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,140,177,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,140,177**;AUG 13, 1993
  ;
  ;List of Team's Members Report
@@ -31,8 +31,6 @@
  .;
  .S TPNODE=$G(^SCTM(404.57,+TPIEN,0))
- .D SETASCL^SCRPRAC2(TPIEN,.PCLIN)
- .S PCLIN=$G(PCLIN(0))
- .;S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien
- .;S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name
+ .S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien
+ .S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name
  .;
  .;Get preceptor
@@ -53,7 +51,4 @@
  .;
  .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS)
- .N SCAC
- .S SCAC=0
- .F  S SCAC=$O(PCLIN(SCAC)) Q:SCAC=""  D FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC))
  Q
  ;
@@ -110,8 +105,4 @@
  Q
  ;
-FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN) ;
- S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$E(PCLIN,1,30)
- Q
- ;
 NEWP(INST,TEM,TITL,PAGE,HEAD) ;
  ;new page
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTP.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,48,174,177,526,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,48,174,177**;AUG 13, 1993
  ;
 PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device
@@ -20,5 +20,5 @@
  ;ROLE - roles selected (variable and array) 
  ;PSTAT - patient status - 1=all or OPT or AC 
- ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
+ ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID
  N ZTSAVE,II
  F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)=""
@@ -31,5 +31,5 @@
  ;ROLE - roles selected (variable and array)
  ;PSTAT - patient status - 1=all or OPT or AC
- ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID
+ ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID
  ;IOP - print device
  ;ZTDTH - queue time (optional)
@@ -114,37 +114,5 @@
  Q FOUND
  ;
-FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information
- ;INS - Institution ien
- ;TIEN - team ien
- ;PTIEN - patient ien
- ;PTNAME - patient name
- ;PID - SSN
- ;PIEN - practitioner ien
- ;PNAME - practitioner name
- ;CNAME - clinic name
- ;LAST - last appointment
- ;NEXT - next appointment
- ;ROLN - role name
- ;PCAP - PC?
- ;
- N SEC,TRD
- I PNAME="" S PNAME="[BAD DATA]"
- I PTNAME="" S PTNAME="[BAD DATA]"
- I PID="" S PID="*********"
- S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner
- S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient
- S @STORE@("PID",INS,TIEN,PID,PTIEN)=""
- I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
- I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
- S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,15) ;patient name
- S $E(@STORE@(INS,TIEN,SEC,TRD),18)=PID ;9 digit pid
- S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name
- S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name
- S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC?
- S $E(@STORE@(INS,TIEN,SEC,TRD),85)=$P(PINF,"^",8) ;last appointment
- S $E(@STORE@(INS,TIEN,SEC,TRD),97)=$P(PINF,"^",9) ;next appointment
- S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name
- Q
-FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES
+FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) ;Format column information
  ;INS - Institution ien
  ;TIEN - team ien
@@ -170,8 +138,11 @@
  I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner
  I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner
- I '$D(@STORE@(INS,TIEN,SEC,TRD,SCCNT))  D
- .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$P(PINF,"^",8) ;last appointment
- .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$P(PINF,"^",9) ;next appointment
- .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$E(CNAME,1,24) ;clinic name
- .Q
+ S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,22) ;patient name
+ S $E(@STORE@(INS,TIEN,SEC,TRD),25)=PID ;last 4 pid
+ S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name
+ S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name
+ S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC?
+ S $E(@STORE@(INS,TIEN,SEC,TRD),85)=LAST ;last appointment
+ S $E(@STORE@(INS,TIEN,SEC,TRD),97)=NEXT ;next appointment
+ S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name
  Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTP2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,53,52,174,177,231,526,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,53,52,174,177,231**;AUG 13, 1993
  ;
  ;List of Team's Patients Report
@@ -73,7 +73,4 @@
  . . . . Q:STOP
  . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data
- . . . . N SCACL
- . . . . S SCACL="" F  S SCACL=$O(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) Q:SCACL=""  D
- . . . . . W !,$G(@STORE@(INST,TIEN,PIEN,TRDI,SCACL))
  . S NEW=0
  Q
@@ -102,7 +99,4 @@
  . . . . Q:STOP
  . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data
- . . . . N SCACL
- . . . . S SCACL="" F  S SCACL=$O(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) Q:SCACL=""  D
- . . . . . W !,$G(@STORE@(INST,TIEN,TRDI,PIEN,SCACL))
  . S NEW=0
  Q
@@ -137,5 +131,5 @@
 SETH ;sets column headings
  S @STORE@("H2")="Patient Name"
- S $E(@STORE@("H2"),18)="Pt ID"
+ S $E(@STORE@("H2"),25)="Pt ID"
  S $E(@STORE@("H2"),32)="Practitioner"
  S $E(@STORE@("H2"),56)="Role"
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP3.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPTP3.m	(revision 636)
@@ -1,5 +1,4 @@
 SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99  04:11PM
- ;;5.3;Scheduling;**41,48,98,177,231,433,526,520**;AUG 13, 1993;Build 26
- ;;DMR BP-OIFO Patch SD*5.3*526
+ ;;5.3;Scheduling;**41,48,98,177,231,433**;AUG 13, 1993
  ;
  ;List of Team's Patients Report
@@ -25,15 +24,54 @@
  .S DFN=PTIEN
  .D PID^VADPT6
- .;S PID=VA("BID")
- .S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12)
+ .S PID=VA("BID")
  .;
- .N CNAME,PINF,CLIEN
+ .S TPA=$$TPAR(PTAI,"")
+ .I TPA'=-1 D
+ ..S PIEN=$P(TPA,"^")
+ ..S PNAME=$P(TPA,"^",2)
+ ..S CNAME=$P(TPA,"^",3)
+ ..S LAST=$P(TPA,"^",4)
+ ..S NEXT=$P(TPA,"^",5)
+ ..;
+ ..S FLAG="Y"
+ ..S TINFO=$$TINF^SCRPTP(TIEN) ;team information
+ ..S INST=+$P(TINFO,"^") ;institution ien
+ ..S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
+ ..S PHONE=$P(TINFO,"^",4) ;team phone
+ ..S PC=$P(TINFO,"^",3) ;primary care?
+ ..S TNAME=$P(TINFO,"^",2) ;team name
+ ..;
+ ..D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
+ ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT)
+ .;
+ .;check for other assignments
+ .N TPIN
  .S CNT=""
  .F  S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N)  D
- ..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP)
+ ..S TPIN=$$TPAR(PTAI,CNT)
+ ..Q:TPIN=-1
+ ..S PIEN=$P(TPIN,"^")
+ ..S PNAME=$P(TPIN,"^",2)
+ ..S CNAME=$P(TPIN,"^",3)
+ ..S LAST=$P(TPIN,"^",4)
+ ..S NEXT=$P(TPIN,"^",5)
+ ..S ROLN=$P(TPIN,U,6)
+ ..S PCAP=$P(TPIN,U,7)
+ ..I '$D(FLAG) D
+ ...S TINFO=$$TINF^SCRPTP(TIEN) ;team information
+ ...S INST=+$P(TINFO,"^") ;institution ien
+ ...S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
+ ...S PHONE=$P(TINFO,"^",4) ;team phone
+ ...S PC=$P(TINFO,"^",3) ;primary care?
+ ...S TNAME=$P(TINFO,"^",2) ;team name
+ ...;
+ ...D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
+ ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP)
+ I INACTIVE S @STORE@(INST,TIEN,"INACT")=""
  Q
  ;
-TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ;
- N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN
+TPAR(PTAI,START) ;
+ N PTPA,TPIEN,TPNODE,ROL,CNAME,CIEN,ENROLL,OKAY,PNAME,NEXT,LAST,PAIEN
+ N ROLN,PCAP
  I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]"
  ; ^ no patient team position assignment
@@ -43,5 +81,5 @@
  .S PTPA=START
  I PTPA="" Q "0^[Not Assigned]"
- S PTPAN=$G(^SCPT(404.43,PTPA,0))  ;patient team assignment
+ S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team position assignment node
  I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]"
  I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)<DT Q -1
@@ -57,5 +95,12 @@
  S PCAP=$S($P(PTPAN,U,5)<1:"NPC",+$$OKPREC3^SCMCLK(TPIEN,DT)>0:" AP",1:"PCP") ;PC?
  ;
- D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN)
+ S CIEN=+$P(TPNODE,"^",9) ;associated clinic ien
+ S CNAME=$P($G(^SC(CIEN,0)),"^") ;clinic name
+ ;check patient status
+ S OKAY=""
+ I CIEN>0&(PSTAT'=1) S OKAY=$$PST^SCRPTP(PTIEN,CIEN)
+ Q:(CIEN>0)&('OKAY)&(PSTAT'=1) -1
+ ; ^ not selected patient status
+ ;
  ;next two lines commented off - SD*5.3*433
  ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic
@@ -67,37 +112,24 @@
  I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]"
  ;
- D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF)  ;get patient info
- S CNAME=$G(CNAME(0))
- S PINF=$G(PINF(0))
- I PINF="" D
- .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1)
- I INACTIVE S @STORE@(INS,TIEN,"INACT")=""
- S FLAG="Y"
- S TINFO=$$TINF^SCRPTP(TIEN) ;team information
- S INST=+$P(TINFO,"^") ;institution ien
- S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name
- S PHONE=$P(TINFO,"^",4) ;team phone
- S PC=$P(TINFO,"^",3) ;primary care?
- S TNAME=$P(TINFO,"^",2) ;team name
- D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC)
- D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP)
- N SCCNT
- S SCCNT=0 F  S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT=""  D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP)
- Q
+ S (NEXT,LAST)=""
+ I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment
+ I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment
  ;
-ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED
+ Q PIEN_U_PNAME_U_CNAME_U_LAST_U_NEXT_U_ROLN_U_PCAP
  ;
- ;N FOUND,ENODE,EN,NXT
- ;S FOUND=0
- ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
- ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
- ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
- ;S NXT=""
- ;F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
- ;check if active enrollment
- ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
- ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
- ;;                      ^ discharge date     ^ enrollment date
+ENRL(PTIEN,CLIEN) ;
+ ;
+ N FOUND,ENODE,EN,NXT
  S FOUND=0
+ Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND
+ S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,""))
+ Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND
+ S NXT=""
+ F  S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N)  D
+ .;check if active enrollment
+ .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0))
+ .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)<DT+1!$P(ENODE,"^")>DT Q  ;not active enrollment
+ .;                      ^ discharge date     ^ enrollment date
+ .S FOUND=1
  Q FOUND
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPU1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU1.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96
- ;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993
  ;
 INST ;Prompt for institution
@@ -109,5 +109,5 @@
  N TRUE,EN,TEAM
  S TRUE=0,EN=""
- F  S EN=$O(^SCTM(404.57,"E",+Y,EN)) Q:EN=""!(TRUE)  D
+ F  S EN=$O(^SCTM(404.57,"D",+Y,EN)) Q:EN=""!(TRUE)  D
  .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2)
  .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPU2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPU2.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPU2 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ; 12 Jan 99  1:23 PM
- ;;5.3;Scheduling;**41,174,297,526,520**;AUG 13, 1993;Build 26
+ ;;5.3;Scheduling;**41,174,297**;AUG 13, 1993
  ;
 DTRANG(FIRST,SECOND) ;Date Range - begin date ^ end date => fileman format
@@ -29,5 +29,5 @@
  N TPEN,FOUND,TEAM
  S TPEN="",FOUND=0
- F  S TPEN=$O(^SCTM(404.57,"E",CLN,TPEN)) Q:TPEN=""!(FOUND)  D
+ F  S TPEN=$O(^SCTM(404.57,"D",CLN,TPEN)) Q:TPEN=""!(FOUND)  D
  .S TEAM=$P(^SCTM(404.57,TPEN,0),"^",2)
  .I $D(^SCPT(404.42,"APTTM",DFN,TEAM)) S FOUND=1
@@ -122,14 +122,14 @@
 SORT2() ;Prompt for sorting by:
  ;   [1] Division, Team, Patient Name
- ;or [2] Division, Team, SSN
+ ;or [2] Division, Team, Last 4 Pt ID
  ;or [3] Division, Team, Practitioner, Patient Name
- ;or [4] Division, Team, Practitioner, SSN
+ ;or [4] Division, Team, Practitioner, Last 4 Pt ID
  ;
 EN4 ;
  N X
  W !,"Sort By:",!?10,"[1] Division, Team, Patient Name"
- W !?10,"[2] Division, Team, SSN"
+ W !?10,"[2] Division, Team, Last 4 Pt ID"
  W !?10,"[3] Division, Team, Practitioner, Patient Name"
- W !?10,"[4] Division, Team, Practitioner, SSN"
+ W !?10,"[4] Division, Team, Practitioner, Last 4 Pt ID"
  W !!,"Select 1, 2, 3, or 4: "
  R X:DTIME
@@ -141,6 +141,6 @@
  ;help prompt
  W !,"Enter: ",!?5,"- 1 to sort by Division, Team, Patient Name"
- W !?10,"- 2 to sort by Division, Team, SSN"
+ W !?10,"- 2 to sort by Division, Team, Last 4 Pt ID"
  W !?10,"- 3 to sort by Division, Team, Practitioner, Patient Name"
- W !?10,"- 4 to sort by Division, Team, Practitioner, SSN"
+ W !?10,"- 4 to sort by Division, Team, Practitioner, Last 4 Pt ID"
  Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW24.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW24.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW24.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPW24 ;RENO/KEITH - ACRP Ad Hoc Report (cont.) ;06/19/99
- ;;5.3;Scheduling;**144,163,180,254,243,295,329,351,510**;AUG 13, 1993;Build 3
+ ;;5.3;Scheduling;**144,163,180,254,243,295,329,351**;AUG 13, 1993
  ;06/19/99 ACS - Added CPT modifier API calls
  ;
@@ -189,5 +189,5 @@
  ;
 ENROL(SDATE)  ;Get enrollment record (most recent to encounter date)
- N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F  S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI  S SDY=$G(^DGEN(27.11,SDI,0)),SDY($P($P(^DGEN(27.11,SDI,"U"),U,1),".",1))=SDY  ;SD/510 changed logic to use date/time entered
+ N SDY,SDI,X1,X2,X,%Y S:SDATE#1=0 SDATE=SDATE+.9999 S SDI=0 F  S SDI=$O(^DGEN(27.11,"C",+$P(SDOE0,U,2),SDI)) Q:'SDI  S SDY=$G(^DGEN(27.11,SDI,0)),SDY(+SDY)=SDY
  S SDI=$O(SDY(SDATE),-1) Q:'SDI ""  S X1=$P($P(SDOE0,U),"."),X2=SDI D ^%DTC Q SDY(SDI)
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW6.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW6.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW6.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPW6 ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98  02:38PM
- ;;5.3;Scheduling;**139,144,466,510**;AUG 13, 1993;Build 3
+ ;;5.3;Scheduling;**139,144,466**;AUG 13, 1993;Build 2
  N SDDIV,SDI,SDSTA,DIR D TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges") G:'$$DIVA^SCRPW17(.SDDIV) EXIT
  D SUBT^SCRPW50("**** Status Selection ****")
@@ -7,5 +7,5 @@
  S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8")
 QUE W !!,"This report requires 132 column output.",!
- N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(","SDSTA" S ZTSAVE(X)=""
+ N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(",SDSTA S ZTSAVE(X)=""
  D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q
 UNIQ ;Calculate/print uniques
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW8.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW8.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW8.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPW8 ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99  4:53 PM
- ;;5.3;Scheduling;**139,145,144,176,339,466,510**;AUG 13, 1993;Build 3
+ ;;5.3;Scheduling;**139,145,144,176,339,466**;AUG 13, 1993;Build 2
 QS ;Queue outpatient encounter workload report
  D PARM^SCRPW9 Q
@@ -28,10 +28,10 @@
 PRPT ;Print statistics page
  D STOP Q:SDOUT
- S SDCT=0 F SDI=1,2,3,11,14,"8-CC" S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
+ S SDCT=0 F SDI=1,2,3,11,14,8 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
  D XHDR Q:SDOUT  D SHDR("O U T P A T I E N T   E N C O U N T E R   W O R K L O A D") Q:SDOUT  F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT
  I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"CHECKED OUT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT
- I $D(^TMP(SDS1,$J,SDS2,"8-CC")) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"INPATIENT APPOINTMENT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI,"")) D IAP
- D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,"8-NC",9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
- W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT  F SDI="8-NC",12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT
+ I $D(^TMP(SDS1,$J,SDS2,8)) D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"INPATIENT APPOINTMENT" S SDI=0 F  S SDI=$O(^TMP(SDS1,$J,SDS2,8,SDI)) Q:'SDI!SDOUT  S SDSTAT=$O(^TMP(SDS1,$J,SDS2,8,SDI,"")) D IAP
+ D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI))
+ W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT  F SDI=12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT
  D TOT W !! D SHDR(($$HD2()_"   O U T P A T I E N T   V I S I T S")) Q:SDOUT  S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK")
  D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2)
@@ -52,5 +52,5 @@
 EXIT K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE
  D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J)
- K I,SDFF,SDOUT,SDSTOP,SDNCOU D END^SCRPW50 Q
+ K I,SDFF,SDOUT,SDSTOP D END^SCRPW50 Q
  ;
 HD1() ;Report subheader 1
@@ -83,15 +83,14 @@
  ;
 LIST(SDI) Q:'$D(^TMP(SDS1,$J,SDS2,SDI))  D:$Y>(IOSL-4) XHDR Q:SDOUT
- W !?10,$P(^SD(409.63,+SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2)
+ W !?10,$P(^SD(409.63,SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2)
  Q
  ;
 COT D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q
  ;
-IAP D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT)*100/SDCT)),8,2) Q
+IAP D:$Y>(IOSL-4) XHDR Q:SDOUT  W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT)*100/SDCT)),8,2) Q
 STOP ;Check for stop task request
  S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
  ;
 COUNT ;Count encounters
- S SDNCOU=$P($G(^SC(+$P(SDOE0,U,4),0)),U,17),SDNCOU=$S(SDNCOU="Y":1,1:0)
  S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT
  D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q
@@ -99,14 +98,9 @@
 C1(SDS1,SDS2) ;Set ^TMP global
  ;Required input: SDS1,SDS2=subscript values
- ;Because there is only 1 status (8) for INPATIENTS, 8-NC is used to
- ;distinguish the non-count clinics from the count clinics, 8-CC.
- S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDSTAT=8 S SDSTAT=$S(SDNCOU:SDSTAT_"-NC",1:SDSTAT_"-CC")
- I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL
+ S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL
  S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1
- Q:SDSTAT=4  Q:(+SDSTAT=8)&($P(SDSTAT,"-",2)="NC")  D:"114238"[+SDSTAT VIS Q
+ Q:SDSTAT=4  D:"114238"[SDSTAT VIS Q
  ;
-VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",(+SDSTAT=8)&('SDNCOU):"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(+SDSTAT'=2)&(+SDSTAT'=8)
- I +SDSTAT=8,$P(SDOE0,U,7)="" D  Q
- .S ^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required")=$G(^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required"))+1
+VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",SDSTAT=8:"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(SDSTAT'=2)&(SDSTAT'=8)
  S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1
  Q:$P(SDSTX,U)'=8  S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))=""
@@ -129,15 +123,10 @@
  ;
 DETAIL ;Set global for detailed list
- N SDIF S SDIF=0
  D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U)
- I SDZ(1)="U",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q
- I SDZ(1)="V",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q
+ I SDZ(1)="U",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q
+ I SDZ(1)="V",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q
  Q:'$D(SDZ(2))  ; SD*5.3*339
- I SDZ(2)'=2,SDZ(2)=+SDSTAT D  I SDIF Q
- .I (SDZ(2)=8) Q:$P(SDSTAT,"-",2)="CC"  I SDZ(3)'=9 S SDIF=1 Q
- .D DSET S SDIF=1
- Q:("28"'[SDZ(2))!("28"'[+SDSTAT)  Q:SDZ(2)'=+SDSTAT  D  I SDIF Q
- .I +SDSTAT=8,$P(SDSTAT,"-",2)="NC" S SDIF=1 Q
- .I 'SDZ(3) D DSET S SDIF=1
+ I (SDZ(2)'=2)&(SDZ(2)'=8),SDZ(2)=SDSTAT D DSET Q
+ Q:("28"'[SDZ(2))!("28"'[SDSTAT)!(SDZ(2)'=SDSTAT)  I 'SDZ(3) D DSET Q
  D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW9.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW9.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW9.m	(revision 636)
@@ -1,4 +1,4 @@
 SCRPW9 ;RENO/KEITH - Outpatient Encounter Workload Statistics (cont.) ; 15 Jul 98  02:38PM
- ;;5.3;Scheduling;**139,144,339,466,510**;AUG 13, 1993;Build 3
+ ;;5.3;Scheduling;**139,144,339,466**;AUG 13, 1993;Build 2
 UNARL(SDS1,SDS2) ;Print list of 'action required'/not accepted uniques
  ;Required input: SDS1,SDS2=subscript values
@@ -34,5 +34,4 @@
  S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;"
  S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted"
- I SDZ(2)=8 S DIR(0)=DIR(0)_";9:Non-Count (not transmitted)"
  W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q  ;SD*5.3*339 add sub-zero
  S SDZ(3)=+Y
@@ -47,5 +46,5 @@
  K SDH S SDPAGE=1,SDH(1)="<*>  DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_"  <*>",SDH(2)="For division: "_SDZ(4)
  I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status"
- I $G(SDZ(2))'="","28"[SDZ(2) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2)
+ I "28"[$G(SDZ(2)) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2)
  D DHDR Q:SDOUT  I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q
  S SDCT=0 D @SDZ(1) Q
@@ -90,5 +89,4 @@
  ;Transmitted, error
  ;Transmitted, accepted
- ;Non-Count (not transmitted)
  ;
 PARM ;Prompt for report parameters
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMBAE2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDAMBAE2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMBAE2.m	(revision 636)
@@ -1,4 +1,4 @@
 SDAMBAE2 ;ALB/BOK - ADD/EDIT CON'T ;11/21/91  12:15 ;
- ;;5.3;Scheduling;**15,79,111,132**;Aug 13, 1993
+ ;;5.3;Scheduling;**15,79,111,132**;Aug 13, 1993;Build 1
  ;
 APP ; -- screen on APPOINTMENT TYPE field in VISIT file CLINIC STOP multiple
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMBAE3.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDAMBAE3.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMBAE3.m	(revision 636)
@@ -1,4 +1,4 @@
 SDAMBAE3 ;ALB/BOK/MJK - ADD/EDIT CON'T ;7/8/91  12:18 ;
- ;;5.3;Scheduling;**18,29,40,111,132**;Aug 13, 1993
+ ;;5.3;Scheduling;**18,29,40,111,132**;Aug 13, 1993;Build 1
  ;
 DUP ; -- inp transform to check for duplicate CPTs in ^DD(409.51,21:25,0)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMODO3.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDAMODO3.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDAMODO3.m	(revision 636)
@@ -1,4 +1,4 @@
 SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98  8:44 PM
- ;;5.3;Scheduling;**11,25,46,49,159,529**;Aug 13, 1993;Build 3
+ ;;5.3;Scheduling;**11,25,46,49,159**;Aug 13, 1993
  Q
 REPORT ;
@@ -96,5 +96,5 @@
  N Y S Y=1
  I PDIAG=1 G SELDXQ
- S DIC="^ICD9(",DIC(0)="XMS",X=DX_" "  ;SD/529
+ S DIC="^ICD9(",DIC(0)="MZ",X=DX
  D ^DIC K DIC I Y<0 S Y=0 G SELDXQ
  I $D(PDIAG($P(Y,U))) G SELDXQ
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT ; GENERATED FROM 'SDB' INPUT TEMPLATE(#485), FILE 44;05/05/06
+SDBT ; GENERATED FROM 'SDB' INPUT TEMPLATE(#485), FILE 44;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))=""
@@ -148,5 +148,5 @@
 C12 G C12S:$D(DE(12))[0 K DB
 C12S S X="" G:DG(DQ)=X C12F1 K DB
-C12F1 N X,X1,X2 S DIXR=458 D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X
+C12F1 N X,X1,X2 S DIXR=473 D C12X1(U) K X2 M X2=X D C12X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^SC("AST",X,DA)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT1.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT1 ; ;05/05/06
+SDBT1 ; ;10/02/06
  S X=DE(19),DIC=DIE
  K ^SC("ALTP",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT10.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT10.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT10.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT10 ; ;05/05/06
+SDBT10 ; ;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT11.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT11.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT11.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT11 ; ;04/26/05
+SDBT11 ; ;11/16/05
  D DE G BEGIN
 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT2.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT2 ; ;05/05/06
+SDBT2 ; ;10/02/06
  S X=DG(DQ),DIC=DIE
  S ^SC("ALTP",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT3.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT3.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT3.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT3 ; ;05/05/06
+SDBT3 ; ;10/02/06
  S X=DE(20),DIC=DIE
  K ^SC("ALTC",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT4.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT4.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT4.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT4 ; ;05/05/06
+SDBT4 ; ;10/02/06
  S X=DG(DQ),DIC=DIE
  S ^SC("ALTC",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT5.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT5.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT5.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT5 ; ;05/05/06
+SDBT5 ; ;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(",DIC=DIE,DP=44,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SC(DA,""))=""
@@ -141,5 +141,5 @@
 C16 G C16S:$D(DE(16))[0 K DB
 C16S S X="" G:DG(DQ)=X C16F1 K DB
-C16F1 N X,X1,X2 S DIXR=457 D C16X1(U) K X2 M X2=X D C16X1("O") K X1 M X1=X
+C16F1 N X,X1,X2 S DIXR=472 D C16X1(U) K X2 M X2=X D C16X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^SC("ACST",X,DA)
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT6.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT6.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT6.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT6 ; ;05/05/06
+SDBT6 ; ;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(D0,""PR"",",DIC=DIE,DP=44.1,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"PR",DA,""))=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT7.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT7.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT7.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT7 ; ;05/05/06
+SDBT7 ; ;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(D0,""DX"",",DIC=DIE,DP=44.11,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"DX",DA,""))=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT8.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT8.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT8.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT8 ; ;05/05/06
+SDBT8 ; ;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(D0,""SDPRIV"",",DIC=DIE,DP=44.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"SDPRIV",DA,""))=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT9.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDBT9.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDBT9.m	(revision 636)
@@ -1,3 +1,3 @@
-SDBT9 ; ;05/05/06
+SDBT9 ; ;10/02/06
  D DE G BEGIN
 DE S DIE="^SC(D0,""SI"",",DIC=DIE,DP=44.03,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SC(D0,"SI",DA,""))=""
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDC.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDC.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDC.m	(revision 636)
@@ -1,4 +1,4 @@
 SDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm
- ;;5.3;Scheduling;**15,32,79,132,167,478,487,523**;Aug 13, 1993;Build 6
+ ;;5.3;Scheduling;**15,32,79,132,167,478,487**;Aug 13, 1993
  N SDATA,SDCNHDL ; for evt dvr
 SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL
@@ -39,11 +39,9 @@
  D S S ^(1)="   "_$E(SD,6,7)_"    **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1)
 C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'<TO) W !!,"CANCELLED!  " K SDX G CHKEND^SDC0
- N TDH,TMPD,DIE,DR,NODE
+ N TDH,TMPD,DIE,DR
  F I=0:0 S I=$O(^SC(SC,"S",FR,1,I)) Q:I'>0  D
  .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1)
  .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL)
  .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C"
- .S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0)  ;added SD/523
- .Q:$P(NODE,U,1)'=SC                  ;added SD/523
  .S ^DPT("ASDCN",SC,FR,DFN)=""
  .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCLAS.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDCLAS.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCLAS.m	(revision 636)
@@ -1,4 +1,4 @@
 SDCLAS ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92  11:42
- ;;5.3;Scheduling;**63,243,517,523**;Aug 13, 1993;Build 6
+ ;;5.3;Scheduling;**63,243,517**;Aug 13, 1993;Build 4
  ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS
  S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0
@@ -14,10 +14,10 @@
  S PGM="START^SDCLAS",VAR="SDIFN^SDSRT^DIV^SDTS^SDSAV^SDFAST",VAL=SDIFN_"^"_SDSRT_"^"_DIV_"^"_SDTS_"^"_SDSAV_"^"_SDFAST D ZIS^DGUTQ Q:POP
 START K ^UTILITY($J) S SDSTOP=$S(SDSRT="S":SDIFN,1:""),SD1="",U="^" U IO G:SDIFN="ALL"!(SDSRT="S")!(SDSAV]"") ALL
-ONE S ONE=1 D INIT F SDAPPT=SDTS:0 S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) Q:SDAPPT'>0  D PT
+ONE S ONE=1 D INIT S SDAPPT=0 F  S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) Q:'SDAPPT  D PT
  D:'SDFAST AEB^SDCLAS0 G ^SDCLAS1
 ALL S ONE=0 I SDSAV']"" S SDIFN=0 F  S SDIFN=$O(^SC(SDIFN)) Q:'SDIFN  I $P(^(SDIFN,0),"^",3)="C" D APPT
  I SDSAV]"" D APART S SDIFN=0 F  S SDIFN=$O(SDZ(SDIFN)) Q:'SDIFN  I $D(^SC(SDIFN,0)),$P(^(0),"^",3)="C" D APPT
  G ^SDCLAS1
-APPT D CHECK I 'POP K ^UTILITY($J,"PAT",SDIFN) D INIT F SDAPPT=SDTS:0 S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) D:SDAPPT>0 PT I SDAPPT'>0 D:'SDFAST AEB^SDCLAS0 Q
+APPT D CHECK I 'POP K ^UTILITY($J,"PAT",SDIFN) D INIT S SDAPPT=0 F  S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) D:SDAPPT PT I 'SDAPPT D:'SDFAST AEB^SDCLAS0 Q
  Q
 PT S SD=0 F  S SD=$O(^SC(SDIFN,"S",SDAPPT,1,SD)) Q:'SD  Q:'$D(^(SD,0))  S DFN=+^(0) D PT1
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCLAV0.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDCLAV0.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCLAV0.m	(revision 636)
@@ -1,11 +1,9 @@
 SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM
- ;;5.3;Scheduling;**184,439,490,517,529**;Aug 13, 1993;Build 3
+ ;;5.3;Scheduling;**184,439,490,517**;Aug 13, 1993;Build 4
  ;SD/517 CHANGED FOR LOOPS
  I 'VAUTC S SDC=0 F  S SDC=$O(VAUTC(SDC)) Q:'SDC  S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1
  I VAUTC S SDC=0 F  S SDC=$O(^SC(SDC)) Q:'SDC  I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1
  I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1
- ;following line commented off per SD*529
- ;S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q
- D END^SDCLAV Q
+ S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q
 S1 S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^")
  S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCWL2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDCWL2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDCWL2.m	(revision 636)
@@ -1,4 +1,4 @@
 SDCWL2 ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99  6:41 PM
- ;;5.3;Scheduling;**140,132,171,184,529**;Aug 13, 1993;Build 3
+ ;;5.3;Scheduling;**140,132,171,184**;Aug 13, 1993
 PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7)
 PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0)
@@ -9,5 +9,5 @@
  Q:$D(SDFL)!(SDRT="B")  S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0
  S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4)
- S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=1:"S",SDP=3:"S",SDP=4:"U",1:" "))=""  ;added SDP=1 SD*529
+ S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=3:"S",SDP=4:"U",1:" "))=""
  K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q
  I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDD0.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDD0.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDD0.m	(revision 636)
@@ -1,4 +1,4 @@
 SDD0 ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84  3:00 pm
- ;;5.3;Scheduling;**167,401,529**;Aug 13, 1993;Build 3
+ ;;5.3;Scheduling;**167,401**;Aug 13, 1993
 SETX ;
  N SDDIV
@@ -8,5 +8,5 @@
  S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1)
  K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y
- F DATE=$$FMADD^XLFDT(SDBD,-1):0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED)  I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK  ;changed 1st part of For loop SD*529
+ F DATE=SDBD-1:0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED)  I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK
  Q
 CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDLT.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDLT.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDLT.m	(revision 636)
@@ -1,4 +1,4 @@
 SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003
- ;;5.3;Scheduling;**185,213,281,330,398,523**;Aug 13, 1993;Build 6
+ ;;5.3;Scheduling;**185,213,281,330,398**;Aug 13, 1993
  ;
  ;**************************************************************************
@@ -14,7 +14,5 @@
  ;
  ;WRITE GREETING AND OPENING TEXT OF LETTER
-PRT S DFN=$P(A,U,1)  ;SD*523
- I $D(SDNOSH) I $D(^DPT(DFN,.1)) S POP=1 Q:POP  ;SD/523
- S Y=DT D DTS^SDUTL
+PRT S Y=DT D DTS^SDUTL
  I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1
  K SDFIRST
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDN1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDN1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDN1.m	(revision 636)
@@ -1,4 +1,4 @@
 SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84  4:34 pm
- ;;5.3;Scheduling;**330,340,398,455,523**;Aug 13, 1993;Build 6
+ ;;5.3;Scheduling;**330,340,398,455**;Aug 13, 1993
  N SDBAD
  I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0  F C=0:0 S C=$O(^(A,C)) Q:C'>0  S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL
@@ -9,5 +9,5 @@
 LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0  D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER
 LST N SDFIRST S SDFIRST=1
- F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0  F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0  I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) N POP S POP=0 D ^SDLT Q:POP  D WR  ;SD*523 added quit
+ F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0  F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0  I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) D ^SDLT,WR
  I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0  F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0  Q:$$BADADR^DGUTL3(A)  W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT
  W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!!
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDNOS0.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDNOS0.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDNOS0.m	(revision 636)
@@ -1,4 +1,4 @@
 SDNOS0 ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM
- ;;5.3;Scheduling;**20,194,410,517,523**;Aug 13, 1993;Build 6
+ ;;5.3;Scheduling;**20,194,410,517**;Aug 13, 1993;Build 4
  D END1^SDNOS
  S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV
@@ -33,6 +33,5 @@
  Q
  ;Added 2nd Quit below SD/517
- ;SD/523 - added Q:SDPAT="" to For loop
-CHK S SDAPP=0 F  S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP  Q:'$D(^(SDAPP,0))  I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) Q:SDPAT=""  I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1
+CHK S SDAPP=0 F  S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP  Q:'$D(^(SDAPP,0))  I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1
  Q
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDPFSS.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDPFSS.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDPFSS.m	(revision 636)
@@ -1,4 +1,21 @@
-SDPFSS ;ALB/SCK - Patient Financial Services System  ;22-APR-2005
- ;;5.3;Scheduling;**430**;Aug 13, 1993
+SDPFSS ;ALB/SCK - Patient Financial Services System  ;11/24/0622-APR-2005
+ ;;5.3;Scheduling;**430,502**;Aug 13, 1993  ;Build 14
+ ; Modified from FOIA VISTA,
+ ; Copyright (C) 2007 WorldVistA
+ ;
+ ; This program is free software; you can redistribute it and/or modify
+ ; it under the terms of the GNU General Public License as published by
+ ; the Free Software Foundation; either version 2 of the License, or
+ ; (at your option) any later version.
+ ;
+ ; This program is distributed in the hope that it will be useful,
+ ; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ; GNU General Public License for more details.
+ ;
+ ; You should have received a copy of the GNU General Public License
+ ; along with this program; if not, write to the Free Software
+ ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
+ ;
  ;
  Q
@@ -11,12 +28,20 @@
  ; Check conditions before proceeding
  Q:'$G(DFN)
+ ; VWSD LOCAL MOD HERE SDVWNVAI VARIABLE, SEE DEFINITION AT VWSD LOCAL MOD BELOW
+ I $D(SDVWNVAI) G OVER
  Q:'$$CHECK
+OVER ;
+ ;END LOCAL MOD
  Q:$$TESTPAT^VADPT(DFN)
- ;
+ ;VWSD LOCAl MOD
  ; Call the ICN API to generate an ICN if one does not exist for the patient.
+ ;VWSD SDVWNVAI VARIABLE -LOCAL MOD FOR disabling the need for ICN or use of other ICN system for non-VA system
  S SDOK=$$ICNLC^MPIF001(DFN)
- I SDOK<0 D
+ I $D(SDVWNVAI) G OVER1
+ I (SDOK<0) D
  . D ERRMSG^SDPFSS2(SDOK)
  ;
+OVER1 ;
+ ;END LOCAL MOD
  ; Get event type
  S SDEVENT=$S($D(SDAMEVT):$$GET1^DIQ(409.66,SDAMEVT,.01),1:"OTHER")
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLE.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLE.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLE.m	(revision 636)
@@ -1,4 +1,4 @@
-SDWLE ;BPOI/TEH - WAITING LIST-ENTER/EDIT;06/12/2002
- ;;5.3;scheduling;**263,415,446,524**;08/13/93;Build 29
+SDWLE ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 20 Aug 2002  2:10 PM
+ ;;5.3;scheduling;**263,446**;AUG 13 1993;Build 77
  ;
  ;
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLI.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLI.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLI.m	(revision 636)
@@ -1,4 +1,4 @@
-SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05
- ;;5.3;scheduling;**263,327,394,446,524**;08/13/93;Build 29
+SDWLI ;IOFO BAY PINES/TEH - DISPLAY PENDING APPOINTMENTS ; 6/1/05 12:56pm  ; Compiled April 16, 2007 10:00:47
+ ;;5.3;scheduling;**263,327,394,446**;AUG 13 1993;Build 77
  ;
  ;
@@ -30,9 +30,9 @@
  ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0).
  ;
- D SEL G EN:$D(DUOUT)
  D PAT Q:'$D(SDWLDFN)
  G END:SDWLDFN<0,END:SDWLDFN=""
  Q:$D(DUOUT)
 EN1 K DIR,DIC,DR,DIE,SDWLDRG
+ D SEL G EN:$D(DUOUT)
  D GETFILE
  D DISP G EN:'$D(DUOUT)
@@ -40,6 +40,4 @@
  Q
 PAT ;PATIENT LOOK-UP
- ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES
- S DIC("S")="I $D(SDWLY),SDWLY,$P(^SDWL(409.3,+Y,0),U,17)=""O"""
  S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2)
  G PATEND:SDWLDFN=""
@@ -51,5 +49,5 @@
  ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES
  ;
-SEL K SDWLDRG S DIR(0)="Y" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES"
+SEL K SDWLDRG S DIR(0)="YAO^^" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists? Yes// "
  S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records."
  W ! D ^DIR S SDWLY=Y W !
@@ -104,5 +102,5 @@
  .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11)
  .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"")
- .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8),SDWLCOM=$P($P(X,U,18),"~",1)
+ .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8,1:0),SDWLCOM=$P($P(X,U,18),"~",1)
  .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D
  ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3)
@@ -165,4 +163,3 @@
  K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY
  K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP
- K SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY
  Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLQSR.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLQSR.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLQSR.m	(revision 636)
@@ -1,4 +1,4 @@
-SDWLQSR ;BPOI/TEH - WAIT LIST STAT REPORT;06/12/02
- ;;5.3;scheduling;**263,425,448,524**;08/13/93;Build 29
+SDWLQSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT
+ ;;5.3;scheduling;**263,425,448**;AUG 13 1993
  ;
  ;
@@ -7,9 +7,7 @@
  ;
 EN N ZCODE,ZTDESC,ZTDTH,ZTIO,ZTQUEDED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP
- K ^TMP("SDWLQSR",$J)
  D HD
 1 D INS G END:$D(DUOUT)
 2 D DATE G END:$D(DUOUT)
-3 D EXCL G END:$D(DUOUT)
  D QUE G END:$D(DUOUT)
  Q
@@ -35,14 +33,4 @@
  S ^TMP("SDWLQSR",$J,"DATE")=SDWLBDT_"^"_SDWLEDT K DIR,DIC,DIE,%DT Q
  Q
-EXCL ;EXCLUDE # REMAINING =0 - PATCH SD*5.3*524
- S SDWLEXCL=0,^TMP("SDWLQSR",$J,"EXCL")=0
- S DIR("A",1)="Do you wish to exclude any Teams, Specialities or Specific"
- S DIR("A")="Clinics where ALL values are zero"
- S DIR("B")="YES",DIR(0)="Y^A0" D ^DIR
- I X["^" S DUOUT=1 Q
- I Y<0 S DUOUT=1 Q
-EXCL1 I Y S SDWLEXCL=1,^TMP("SDWLQSR",$J,"EXCL")=SDWLEXCL
- K DIR,X,Y,SDWLEXCL
- Q
 QUE ;Queue Report
  N ZTQUEUED,POP
@@ -60,7 +48,5 @@
  D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  Q
-END D EN^SDWLKIL
- K DUOUT,SDWLBDT,SDWLEDT,SDWLERR,SDWLIST,SDWLPROM,SDWLTK
- Q
+END D EN^SDWLKIL Q
 HD ;
  W:$D(IOF) @IOF W !,?80-$L("Wait List Stat Report")\2,"Wait List Stat Report",!
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRP4.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLRP4.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRP4.m	(revision 636)
@@ -1,4 +1,21 @@
 SDWLRP4 ;IOFO BAY PINES/TEH - WAITING LIST - MERGE RPC;06/28/2002 ; 26 Aug 2002  1:25 PM
- ;;5.3;scheduling;**263,485,497**;AUG 13 1993;Build 3
+ ;;5.3;scheduling;**263**;AUG 13 1993;Build 4
+ ;Modified from FOIA VISTA,
+ ;Copyright 2008 WorldVistA.  Licensed under the terms of the GNU
+ ;General Public License See attached copy of the License.
+ ;
+ ;This program is free software; you can redistribute it and/or modify
+ ;it under the terms of the GNU General Public License as published by
+ ;the Free Software Foundation; either version 2 of the License, or
+ ;(at your option) any later version.
+ ;
+ ;This program is distributed in the hope that it will be useful,
+ ;but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;GNU General Public License for more details.
+ ;
+ ;You should have received a copy of the GNU General Public License along
+ ;with this program; if not, write to the Free Software Foundation, Inc.,
+ ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  ;
 INPUT(SDWLRES,SDWLSTR) ;
@@ -83,32 +100,19 @@
  ;SDWLE=4 = UNDETERMINED
  ;
- S SDWLDE=+$H,SDWLE=0,(SDWLEE,SDWLRNED,SDWLDB)=0 D SB1
+ S SDWLDE=+$H,SDWLE=1,SDWLEE=0 D SB1
  G SB0:SDWLE=2
- S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) G SB0:$P(SDWLRNE,U,4)="A" S SDWLRNED=$P(SDWLRNE,U,3)
+ S SDWLRNE=$$ENROLL^EASWTAPI(SDWLDFN) S SDWLRNED=$P(SDWLRNE,U,3)
  I SDWLRNED S X=SDWLRNED D H^%DTC S SDWLDS=%H S SDWLDE=+$H,SDWLDET=SDWLDE-SDWLDS I SDWLDET<366 S SDWLE=1
  I $D(SDWLDET),SDWLDET>365 S SDWLE=3
  I 'SDWLRNE S SDWLE=4
-SB0 I $D(SDWLRNE),$P(SDWLRNE,U,4)="A" D
- .I 'SDWLEE.SDWLEE>730!(SDWLEE=730) S SDWLE=4 Q
- .I 'SDWLEE S SDWLE=4 Q
- S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U",1:"U")
+SB0 S SDWLRNE=$S(SDWLE=1:"N",SDWLE=2:"E",SDWLE=3:"P",SDWLE=4:"U")
  ;-Code here for filling in 409.3
  S DR="27////^S X=SDWLRNE",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE
- S DR="27.1////^S X=$S($G(SDWLRNED):SDWLRNED,$G(SDWLD):SDWLD,1:"""")" D ^DIE
- S DR="27.2////^S X=SDWLDB" D ^DIE
  S DR="9////^S X=DUZ" D ^DIE K DIE,DA,DR,%H
- K SDWLRNE,SDWLD,SDWLDE,SDWLEE,SDWLDET,DIC,DIR,DR,DIE,SDWLDS,SDWLE,SDWLRNED
  Q
-SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) N SDWLDB S SDWLE=3 Q
+SB1 I '$D(^DGCN(391.91,"B",SDWLDFN)) S SDWLE=3 Q
  S SDWLX="" F  S SDWLX=$O(^DGCN(391.91,"B",SDWLDFN,SDWLX)) Q:SDWLX=""  D
- .S SDWLY=$G(^DGCN(391.91,SDWLX,0)) D
- ..;CHECK FOR TREATING FACILITY
- ..I $$TF^XUAF4(+$P(SDWLY,U,2)) D
- ...;SORT FOR LAST TREATMENT DATE
- ...S SDWLD=$P(SDWLY,U,3) I SDWLD S SDWLDTF(9999999-SDWLD)=SDWLX
- I '$D(SDWLDTF) Q
- S SDWLDTF=$O(SDWLDTF(0)) I SDWLDTF S (SDWLD,X)=9999999-SDWLDTF D H^%DTC S SDWLEE=SDWLDE-%H,SDWLDB=1 I SDWLEE<730 S SDWLE=2
- I $D(SDWLEE),SDWLEE>730 S SDWLE=3
- K SDWLDTF
+ .S SDWLY=$G(^DGCN(391.91,SDWLX,0)),SDWLD=$P(^(0),U,3) I SDWLD S X=SDWLD D H^%DTC S SDWLEE=SDWLDE-%H I SDWLEE<730 S SDWLE=2
+ .I $D(SDWLEE),SDWLEE>730 S SDWLE=3
  Q
 FDA ;Get data from SDWLSTR string and set FDA.
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRSR.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDWLRSR.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDWLRSR.m	(revision 636)
@@ -1,4 +1,4 @@
-SDWLRSR ;BPOI/TEH - WAIT LIST STAT REPORT;10/01/02
- ;;5.3;scheduling;**263,273,399,412,425,415,524**;08/13/93;Build 29
+SDWLRSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT ; 01 Oct 2002  4:42 PM  ; Compiled December 21, 2006 15:32:50
+ ;;5.3;scheduling;**263,273,399,412,425,415,446**;AUG 13 1993;Build 77
  ;
  ; Removed Sort logic as routine exceeded SACC maximum size of 10000
@@ -15,7 +15,6 @@
  I $D(DATE) S SDWLDATE=DATE
  I $D(INS) S SDWLINS=INS
- I $D(EXCL) S SDWLEXCL=EXCL
  I $D(ZTSAVE) D
- .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS")),SDWLEXCL=$G(ZTSAVE("EXCL"))
+ .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS"))
  I SDWLINS'="ALL" F I=1:1 S SDWL=$P(SDWLINS,";",I) Q:SDWL=""  S SDWL("INS",+SDWL)=""
  S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2),SDWLPG=0
@@ -24,61 +23,58 @@
  Q
 PRT ;PRINT REPORT
- S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,SDWLPG)=0 D HD,HD1 ;SD*5.3*415
+ S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0  ;SD*5.3*446
+ S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLPG)=0 D HD,HD1  ;SD*5.3*415,446
  I '$D(^TMP("SDWLRSR1")) W !!,"No Wait List Data to Report" Q
- S SDWLINS="" F  S SDWLINS=$O(^TMP("SDWLRSR1",$J,SDWLINS)) Q:SDWLINS=""  D  Q:POP  D T2  Q:POP  W !,"________________" I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412 added Quit for early exit
- .I $$S^%ZTLOAD S DUOUT="" Q
- .W !!,"INSTITUTION: ",SDWLINS,! K ^XTMP("SDWLRSR")
+ S SDWLINS="" F  S SDWLINS=$O(^TMP("SDWLRSR1",$J,SDWLINS)) Q:SDWLINS=""  D  Q:POP  D T2  Q:POP  W !,"________________" I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412 added Quit for early exit; 446
+ .I $$S^%ZTLOAD S DUOUT="" Q 
+ .W !!,"INSTITUTION: ",SDWLINS,!
  .S SDWLTY="" F  S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY=""  D  Q:POP  ;SD*5.3*412 added Quit for early exit
- ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY)
+ ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) W !,$E(SDWLTNM,1,15)
  ..S SDWLSCN="" F  S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN=""  D  Q:POP  ;SD*5.3*412 added Quit for early exit
- ...S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0 ;SD*5.3*415
  ...S SDWLSCNM="" F  S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM=""  D  Q:POP  D T1  Q:POP  ;SD*5.3*412 added Quit
  ....S SDWLPRI="" F  S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI=""  D  Q:POP  ;SD*5.3*412 added Quit
- .....S SDWLFLG=0
- .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) I SDWLEXCL,SDWLPR S SDWLFLG=1
- .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) I 'SDWLFLG,SDWLEXCL,SDWLCL S SDWLFLG=1
- .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) I 'SDWLFLG,SDWLEXCL,SDWLD S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) I 'SDWLFLG,SDWLEXCL,SDWLNC S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) I 'SDWLFLG,SDWLEXCL,SDWLSA S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) I 'SDWLFLG,SDWLEXCL,SDWLCC S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) I 'SDWLFLG,SDWLEXCL,SDWLNN S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) I 'SDWLFLG,SDWLEXCL,SDWLER S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR"))  I 'SDWLFLG,SDWLEXCL,SDWLTR S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) I 'SDWLFLG,SDWLEXCL,SDWLAD S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) I 'SDWLFLG,SDWLEXCL,SDWLRR S SDWLFLG=1 ;SD*5.3*415
- .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) I 'SDWLFLG,SDWLEXCL,SDWLNR S SDWLFLG=1 ;W ?72,$J(SDWLNR,3)
- .....I 'SDWLEXCL,'SDWLFLG S SDWLFG=1
- .....I SDWLEXCL,'SDWLFLG Q
- .....I '$D(^XTMP("SDWLRSR",$J,SDWLTNM)) W !,$E(SDWLTNM,1,15) S ^XTMP("SDWLRSR",$J,SDWLTNM)=""
- .....W !?2,$E(SDWLSCNM_" "_$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:""),1,17)
- .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR W ?21,$J(SDWLPR,3)
- .....S T2=T2+SDWLCL,TT2=TT2+SDWLCL W ?26,$J(SDWLCL,3)
- .....S T3=T3+SDWLD,TT3=TT3+SDWLD W ?31,$J(SDWLD,3)
- .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC W ?36,$J(SDWLNC,3)
- .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA W ?41,$J(SDWLSA,3)
- .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC W ?46,$J(SDWLCC,3)
- .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN W ?51,$J(SDWLNN,3)
- .....S T8=T8+SDWLER,TT8=TT8+SDWLER W ?56,$J(SDWLER,3)
- .....S T9=T9+SDWLTR,TT9=TT9+SDWLTR W ?61,$J(SDWLTR,3) ;SD*5.3*415
- .....S T10=T10+SDWLAD,TT10=TT10+SDWLAD W ?66,$J(SDWLAD,3) ;SD*5.3*415
- .....S T11=T11+SDWLRR,TT11=TT11+SDWLRR W ?71,$J(SDWLRR,3) ;SD*5.3*415
- .....S T12=T12+SDWLNR,TT12=TT12+SDWLNR W ?76,$J(SDWLNR,3) ;SD*5.3*415
- .....I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412
+ .....N SDWLCLO  ; SD*5.3*446
+ .....W !,?2,$E(SDWLSCNM,1,10)," ",$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:"")
+ .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) W ?20,SDWLPR
+ .....S SDWLCLO=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) W ?27,SDWLCLO  ;SD*5.3*446
+ .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) W ?34,SDWLD  ;SD*5.3*415,446
+ .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) W ?41,SDWLNC  ;SD*5.3*415,446
+ .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) W ?48,SDWLSA  ;SD*5.3*415,446
+ .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) W ?55,SDWLCC  ;SD*5.3*415,446
+ .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) W ?62,SDWLNN  ;SD*5.3*415,446
+ .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) W ?69,SDWLER  ;SD*5.3*415,446
+ .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCL")) W ?76,SDWLCL  ;SD*5.3*415,446
+ .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR")) W ?83,SDWLTR  ;SD*5.3*415,446
+ .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) W ?90,SDWLAD  ;SD*5.3*415,446
+ .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) W ?97,SDWLRR  ;SD*5.3*415,446
+ .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) W ?104,SDWLNR  ;SD*5.3*446
+ .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR
+ .....S T2=T2+SDWLCLO,TT2=TT2+SDWLCLO  ;SD*5.3*446
+ .....S T3=T3+SDWLD,TT3=TT3+SDWLD
+ .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC
+ .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA
+ .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC
+ .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN
+ .....S T8=T8+SDWLER,TT8=TT8+SDWLER
+ .....S T9=T9+SDWLCL,TT9=TT9+SDWLCL  ;SD*5.3*446
+ .....S T10=T10+SDWLTR,TT10=TT10+SDWLTR  ;SD*5.3*446
+ .....S T11=T11+SDWLAD,TT11=TT11+SDWLAD  ;SD*5.3*446
+ .....S T12=T12+SDWLRR,TT12=TT12+SDWLRR  ;SD*5.3*446
+ .....S T13=T13+SDWLNR,TT13=TT13+SDWLNR  ;SD*5.3*446
+ .....I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412,446
  Q
 SCR S DIR(0)="E" D ^DIR S:X="^" POP=1  ;SD*5.3*412
  Q
 T1 ;
- I 'SDWLFLG,SDWLEXCL Q
- W !?20,"---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----"  ;SD*5.3*415
- W !,"Sub-Totals:"
  ;write sub-totals
- W ?21,$J(T1,3),?26,$J(T2,3),?31,$J(T3,3),?36,$J(T4,3),?41,$J(T5,3),?46,$J(T6,3),?51,$J(T7,3),?56,$J(T8,3),?61,$J(T9,3),?66,$J(T10,3),?71,$J(T11,3),?76,$J(T12,3),!  ;SD*5.3*415
- S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0  ;SD*5.3*415
- I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412
+ W !?20,"------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------"  ;SD*5.3*446
+ W !,"Sub-Totals:",?20,T1,?27,T2,?34,T3,?41,T4,?48,T5,?55,T6,?62,T7,?69,T8,?76,T9,?83,T10,?90,T11,?97,T12,?104,T13  ;SD*5.3*446
+ S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0  ;SD*5.3*415,446
+ I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412,446
  Q
 T2 W !,"Institution Totals:"
- W ?21,$J(TT1,3),?26,$J(TT2,3),?31,$J(TT3,3),?36,$J(TT4,3),?41,$J(TT5,3),?46,$J(TT6,3),?51,$J(TT7,3),?56,$J(TT8,3),?61,$J(TT9,3),?66,$J(TT10,3),?71,$J(TT11,3),?76,$J(TT12,3),!  ;SD*5.3*415
- S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12)=0  ;SD*5.3*415
- I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412
+ W ?20,TT1,?27,TT2,?34,TT3,?41,TT4,?48,TT5,?55,TT6,?62,TT7,?69,TT8,?76,TT9,?83,TT10,?90,TT11,?97,TT12,?104,TT13,!  ;SD*5.3*446
+ S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13)=0  ;SD*5.3*415,446
+ I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP  D HD,HD1  ;SD*5.3*412,446
  Q
 HD W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG
@@ -87,14 +83,11 @@
  Q
 HD1 ;
- W !,?20,"PREV"
- W ?65,"#"
- W ?75,"# NOT"
- W !,"WAIT LIST TYPE"
- W ?20,"REMN",?25,"CLSD",?31,"DTH",?37,"NC",?42,"SA",?47,"CC",?52,"NN",?57,"ER",?61,"TR",?65,"ADD",?70,"REMN",?75,"REMVD",!  ;SD*5.3*415
+ W !,?20,"PREV",?90,"#",?97,"#",?104,"# NOT"  ;SD*5.3*415,446
+ W !,"WAIT LIST TYPE",?20,"REMN",?27,"CLSD",?34,"DTH",?41,"NC",?48,"SA",?55,"CC",?62,"NN",?69,"ER",?76,"CL",?83,"TR",?90,"ADD",?97,"REMN",?104,"REMVD"  ;SD*5.3*446
  Q
 END D EN^SDWLKIL
  K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I
- K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE  ;SD*5.3*415
- K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN  ;SD*5.3*415
- K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR  ;SD*5.3*415
+ K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE  ;SD*5.3*415,446
+ K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN  ;SD*5.3*415,446
+ K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR,SDWLCL  ;SD*5.3*415,446
  Q
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXA.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDXA.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXA.m	(revision 636)
@@ -1,3 +1,3 @@
-SDXA ; GENERATED FROM 'SDAMBT' INPUT TEMPLATE(#491), FILE 409.5;05/28/97
+SDXA ; GENERATED FROM 'SDAMBT' INPUT TEMPLATE(#491), FILE 409.5;12/25/06
  D DE G BEGIN
 DE S DIE="^SDV(",DIC=DIE,DP=409.5,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SDV(DA,""))=""
@@ -14,5 +14,5 @@
 B G @DQ
 RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G A:DV'["R",X:'DV,X:D'>0,A
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
 RD G QS:X?."?" I X["^" D D G ^DIE17
  I X="@" D D G Z^DIE2
@@ -20,9 +20,9 @@
 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
  K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
 V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
  S X="?BAD"
@@ -42,8 +42,16 @@
  D ^DIR I 'DDER S %=Y(0),X=Y
  Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="SDXA",DQ=1
- S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=491,U="^"
+ N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ")
+ M DIEZAR=^DIE(491,"AR") S DICRREC="TRIG^DIE17"
+ S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=491,U="^"
 1 S D=0 K DE(1) ;10
- S DIFLD=10,DGO="^SDXA1",DC="14^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D
+ S DIFLD=10,DGO="^SDXA1",DC="15^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D
  S DU="DIC(40.7,"
  I $D(DSC(409.51))#2,$P(DSC(409.51),"I $D(^UTILITY(",1)="" X DSC(409.51) S D=$O(^(0)) S:D="" D=-1 G M1
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXA1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDXA1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXA1.m	(revision 636)
@@ -1,6 +1,7 @@
-SDXA1 ; ;05/28/97
+SDXA1 ; ;12/25/06
  D DE G BEGIN
 DE S DIE="^SDV(D0,""CS"",",DIC=DIE,DP=409.51,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SDV(D0,"CS",DA,""))=""
  I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,7) S:%]"" DE(5)=%
+ I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,1) S:%]"" DE(6)=% S %=$P(%Z,U,2) S:%]"" DE(7)=% S %=$P(%Z,U,3) S:%]"" DE(8)=% S %=$P(%Z,U,4) S:%]"" DE(9)=% S %=$P(%Z,U,5) S:%]"" DE(10)=%
  K %Z Q
  ;
@@ -15,5 +16,5 @@
 B G @DQ
 RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G A:DV'["R",X:'DV,X:D'>0,A
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
 RD G QS:X?."?" I X["^" D D G ^DIE17
  I X="@" D D G Z^DIE2
@@ -21,9 +22,9 @@
 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
  K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
 V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
  S X="?BAD"
@@ -43,4 +44,10 @@
  D ^DIR I 'DDER S %=Y(0),X=Y
  Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="SDXA1",DQ=1
 1 S DW="0;2",DV="P200'",DU="",DLB="EDITED LAST BY",DIFLD=2
@@ -48,5 +55,5 @@
  S X=$S($D(DUZ):DUZ,1:"")
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
 X1 Q
@@ -55,5 +62,5 @@
  S X=$S($D(SDCL):SDCL,1:"")
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
 X2 Q
@@ -63,11 +70,13 @@
  S X=$S(+SDEMP:+SDEMP,'+VAEL(1):"",1:+VAEL(1))
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE
+C3 G C3S:$D(DE(3))[0 K DB
+ S X=DE(3),DIC=DIE
  ;
-C3S S X="" Q:DG(DQ)=X  K DB S X=DG(DQ),DIC=DIE
+C3S S X="" G:DG(DQ)=X C3F1 K DB
+ S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,4,1,1,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(101),U,13),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,4,1,1,1.4)
- Q
+C3F1 Q
 X3 Q
 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;5",DV="R*P409.1'",DU="",DLB="APPOINTMENT TYPE",DIFLD=5
@@ -76,7 +85,8 @@
  S X=SDAPTYP
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE
+C4 G C4S:$D(DE(4))[0 K DB
+ S X=DE(4),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(409.51,5,1,1,2.4)
  S X=DE(4),DIC=DIE
@@ -86,5 +96,6 @@
  S X=DE(4),DIC=DIE
  ;
-C4S S X="" Q:DG(DQ)=X  K DB S X=DG(DQ),DIC=DIE
+C4S S X="" G:DG(DQ)=X C4F1 K DB
+ S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(409.51,5,1,1,1.1) X ^DD(409.51,5,1,1,1.4)
  S X=DG(DQ),DIC=DIE
@@ -94,11 +105,46 @@
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,5,1,4,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^SD(409.1,+$P(Y(101),U,10),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,5,1,4,1.4)
- Q
+C4F1 Q
 X4 Q
 5 D:$D(DG)>9 F^DIE17,DE S DQ=5,DW="0;7",DV="D",DU="",DLB="DATE ENTRY MADE",DIFLD=7
  S X=DT
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
 X5 Q
-6 D:$D(DG)>9 F^DIE17 G ^SDXA2
+6 S DW="PR;1",DV="*P81'X",DU="",DLB="PROCEDURE 1",DIFLD=21
+ S DU="ICPT("
+ S X=$S($D(SDNEW(1)):SDNEW(1),1:"")
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X6 Q
+7 S DW="PR;2",DV="*P81'X",DU="",DLB="PROCEDURE 2",DIFLD=22
+ S DU="ICPT("
+ S X=$S($D(SDNEW(2)):SDNEW(2),1:"")
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X7 Q
+8 S DW="PR;3",DV="*P81'X",DU="",DLB="PROCEDURE 3",DIFLD=23
+ S DU="ICPT("
+ S X=$S($D(SDNEW(3)):SDNEW(3),1:"")
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X8 Q
+9 S DW="PR;4",DV="*P81'X",DU="",DLB="PROCEDURE 4",DIFLD=24
+ S DU="ICPT("
+ S X=$S($D(SDNEW(4)):SDNEW(4),1:"")
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X9 Q
+10 S DW="PR;5",DV="*P81'X",DU="",DLB="PROCEDURE 5",DIFLD=25
+ S DU="ICPT("
+ S X=$S($D(SDNEW(5)):SDNEW(5),1:"")
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X10 Q
+11 G 1^DIE17
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDXACSE.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE.m	(revision 636)
@@ -1,3 +1,3 @@
-SDXACSE ; GENERATED FROM 'SDXACSE' INPUT TEMPLATE(#490), FILE 409.5;05/28/97
+SDXACSE ; GENERATED FROM 'SDXACSE' INPUT TEMPLATE(#490), FILE 409.5;12/25/06
  D DE G BEGIN
 DE S DIE="^SDV(",DIC=DIE,DP=409.5,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^SDV(DA,""))=""
@@ -14,5 +14,5 @@
 B G @DQ
 RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G A:DV'["R",X:'DV,X:D'>0,A
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
 RD G QS:X?."?" I X["^" D D G ^DIE17
  I X="@" D D G Z^DIE2
@@ -20,9 +20,9 @@
 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
  K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
 V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
  S X="?BAD"
@@ -42,14 +42,22 @@
  D ^DIR I 'DDER S %=Y(0),X=Y
  Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="SDXACSE",DQ=1
- S:$D(DTIME)[0 DTIME=300 S D0=DA,DIEZ=490,U="^"
-1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+ N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1("DIEZ")
+ M DIEZAR=^DIE(490,"AR") S DICRREC="TRIG^DIE17"
+ S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_",",DIEZ=490,U="^"
+1 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=1 D X1 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X1 I '$D(SDAPTYP)!('$D(SDAPTYPR))!('$D(SDCPT))!('$D(SDJ)) W !,*7,"Variables must be defined, edit using option." S Y="@89"
  Q
-2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X2 I '$S($D(SDUZ):1,$D(DUZ):1,1:0) W !,*7,"User not defined." S Y="@89"
  Q
 3 S D=0 K DE(1) ;10
- S DIFLD=10,DGO="^SDXACSE1",DC="14^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D
+ S DIFLD=10,DGO="^SDXACSE1",DC="15^409.51P^CS^",DV="409.51P40.7'",DW="0;1",DOW="CLINIC STOP CODE",DLB="Select "_DOW S:D DC=DC_D
  S DU="DIC(40.7,"
  I $D(DSC(409.51))#2,$P(DSC(409.51),"I $D(^UTILITY(",1)="" X DSC(409.51) S D=$O(^(0)) S:D="" D=-1 G M3
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE1.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDXACSE1.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE1.m	(revision 636)
@@ -1,6 +1,8 @@
-SDXACSE1 ; ;05/28/97
+SDXACSE1 ; ;12/25/06
  D DE G BEGIN
 DE S DIE="^SDV(D0,""CS"",",DIC=DIE,DP=409.51,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SDV(D0,"CS",DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=%
+ I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,2) S:%]"" DE(1)=% S %=$P(%Z,U,3) S:%]"" DE(2)=% S %=$P(%Z,U,4) S:%]"" DE(3)=% S %=$P(%Z,U,5) S:%]"" DE(4)=% S %=$P(%Z,U,6) S:%]"" DE(8)=%
+ I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,1) S:%]"" DE(6)=%
+ I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,1) S:%]"" DE(10)=% S %=$P(%Z,U,2) S:%]"" DE(12)=% S %=$P(%Z,U,3) S:%]"" DE(14)=% S %=$P(%Z,U,4) S:%]"" DE(16)=%
  K %Z Q
  ;
@@ -15,5 +17,5 @@
 B G @DQ
 RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G A:DV'["R",X:'DV,X:D'>0,A
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
 RD G QS:X?."?" I X["^" D D G ^DIE17
  I X="@" D D G Z^DIE2
@@ -21,9 +23,9 @@
 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
  K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
 V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
  S X="?BAD"
@@ -43,4 +45,10 @@
  D ^DIR I 'DDER S %=Y(0),X=Y
  Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="SDXACSE1",DQ=1
 1 S DW="0;2",DV="P200'",DU="",DLB="EDITED LAST BY",DIFLD=2
@@ -48,5 +56,5 @@
  S X=$S($D(SDUZ):SDUZ,1:DUZ)
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
 X1 Q
@@ -55,5 +63,5 @@
  S X=$P(SDCPT(SDJ),U,2)
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
 X2 Q
@@ -63,11 +71,13 @@
  S X=$S($G(SDOEP):$P($G(^SCE(SDOEP,0)),U,13),1:"")
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-C3 G C3S:$D(DE(3))[0 K DB S X=DE(3),DIC=DIE
+C3 G C3S:$D(DE(3))[0 K DB
+ S X=DE(3),DIC=DIE
  ;
-C3S S X="" Q:DG(DQ)=X  K DB S X=DG(DQ),DIC=DIE
+C3S S X="" G:DG(DQ)=X C3F1 K DB
+ S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,4,1,1,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^DIC(8,+$P(Y(101),U,13),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,4,1,1,1.4)
- Q
+C3F1 Q
 X3 Q
 4 D:$D(DG)>9 F^DIE17,DE S DQ=4,DW="0;5",DV="R*P409.1'",DU="",DLB="APPOINTMENT TYPE",DIFLD=5
@@ -76,7 +86,8 @@
  S X=SDAPTYP
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-C4 G C4S:$D(DE(4))[0 K DB S X=DE(4),DIC=DIE
+C4 G C4S:$D(DE(4))[0 K DB
+ S X=DE(4),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X="" X ^DD(409.51,5,1,1,2.4)
  S X=DE(4),DIC=DIE
@@ -86,5 +97,6 @@
  S X=DE(4),DIC=DIE
  ;
-C4S S X="" Q:DG(DQ)=X  K DB S X=DG(DQ),DIC=DIE
+C4S S X="" G:DG(DQ)=X C4F1 K DB
+ S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA,DIV(1)=D1 S Y(0)=X S X="369"'[X I X S X=DIV S Y(1)=$S($D(^SDV(D0,"CS",D1,0)):^(0),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(409.51,5,1,1,1.1) X ^DD(409.51,5,1,1,1.4)
  S X=DG(DQ),DIC=DIE
@@ -94,8 +106,74 @@
  S X=DG(DQ),DIC=DIE
  K DIV S DIV=X,D0=DA(1),DIV(0)=D0,D1=DA X ^DD(409.51,5,1,4,89.2) S Y(101)=$S($D(^SCE(D0,0)):^(0),1:"") S X=$S('$D(^SD(409.1,+$P(Y(101),U,10),0)):"",1:$P(^(0),U,1)) S D0=I(0,0) S D1=I(1,0) S DIU=X K Y S X=DIV S X=X X ^DD(409.51,5,1,4,1.4)
- Q
+C4F1 Q
 X4 Q
-5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
 X5 I $D(SDNOTCG) S Y="@1"
  Q
-6 D:$D(DG)>9 F^DIE17 G ^SDXACSE2
+6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="1;1",DV="SI",DU="",DLB="COMPUTER GENERATED?",DIFLD=11
+ S DE(DW)="C6^SDXACSE1"
+ S DU="1:YES;"
+ S X=1
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+C6 G C6S:$D(DE(6))[0 K DB
+ S X=DE(6),DIC=DIE
+ K:X ^SDV("AG",DA(1),DA)
+C6S S X="" G:DG(DQ)=X C6F1 K DB
+ S X=DG(DQ),DIC=DIE
+ S:X ^SDV("AG",DA(1),DA)=""
+C6F1 Q
+X6 Q
+7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X7 I 'SDAPTYPR S Y="@1"
+ Q
+8 D:$D(DG)>9 F^DIE17,DE S DQ=8,DW="0;6",DV="S",DU="",DLB="UNRESOLVED APPT TYPE REASON",DIFLD=6
+ S DU="1:DUAL ELIGIBILITY;2:POSSIBLE COMP & PEN;"
+ S X=SDAPTYPR
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X8 Q
+9 S DQ=10 ;@1
+10 S DW="PR;1",DV="*P81'X",DU="",DLB="PROCEDURE 1",DIFLD=21
+ S DU="ICPT("
+ S X=$P(SDCPT(SDJ),U,3)
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X10 Q
+11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 D X11 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X11 I $P(SDCPT(SDJ),U,4)']"" S Y="@99"
+ Q
+12 S DW="PR;2",DV="*P81'X",DU="",DLB="PROCEDURE 2",DIFLD=22
+ S DU="ICPT("
+ S X=$P(SDCPT(SDJ),U,4)
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X12 Q
+13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X13 I $P(SDCPT(SDJ),U,5)']"" S Y="@99"
+ Q
+14 S DW="PR;3",DV="*P81'X",DU="",DLB="PROCEDURE 3",DIFLD=23
+ S DU="ICPT("
+ S X=$P(SDCPT(SDJ),U,5)
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X14 Q
+15 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=15 D X15 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X15 I $P(SDCPT(SDJ),U,6)']"" S Y="@99"
+ Q
+16 S DW="PR;4",DV="*P81'X",DU="",DLB="PROCEDURE 4",DIFLD=24
+ S DU="ICPT("
+ S X=$P(SDCPT(SDJ),U,6)
+ S Y=X
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ G RD:X="@",Z
+X16 Q
+17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
+X17 I $P(SDCPT(SDJ),U,7)']"" S Y="@99"
+ Q
+18 D:$D(DG)>9 F^DIE17 G ^SDXACSE2
Index: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE2.m
===================================================================
--- FOIAVistA/trunk/r/SCHEDULING-SD-SC/SDXACSE2.m	(revision 631)
+++ FOIAVistA/tag/r/SCHEDULING-SD-SC/SDXACSE2.m	(revision 636)
@@ -1,8 +1,6 @@
-SDXACSE2 ; ;05/28/97
+SDXACSE2 ; ;12/25/06
  D DE G BEGIN
 DE S DIE="^SDV(D0,""CS"",",DIC=DIE,DP=409.51,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^SDV(D0,"CS",DA,""))=""
- I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,6) S:%]"" DE(3)=%
- I $D(^(1)) S %Z=^(1) S %=$P(%Z,U,1) S:%]"" DE(1)=%
- I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,1) S:%]"" DE(5)=% S %=$P(%Z,U,2) S:%]"" DE(7)=% S %=$P(%Z,U,3) S:%]"" DE(9)=% S %=$P(%Z,U,4) S:%]"" DE(11)=% S %=$P(%Z,U,5) S:%]"" DE(13)=%
+ I $D(^("PR")) S %Z=^("PR") S %=$P(%Z,U,5) S:%]"" DE(1)=%
  K %Z Q
  ;
@@ -17,5 +15,5 @@
 B G @DQ
 RE G PR:$D(DE(DQ)) D W,TR
-N I X="" G A:DV'["R",X:'DV,X:D'>0,A
+N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A
 RD G QS:X?."?" I X["^" D D G ^DIE17
  I X="@" D D G Z^DIE2
@@ -23,9 +21,9 @@
 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I  W:'$D(DB(DQ)) "  "_% G V
  K DDER G X
-P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) I DV'["*" D ^DIC S X=+Y,DIC=DIE G X:X<0
+P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0
  G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z
  I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X
 V D @("X"_DQ) K YS
-Z K DIC("S"),DLAYGO I $D(X),X'=U S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
+Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A
 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17
  S X="?BAD"
@@ -45,76 +43,18 @@
  D ^DIR I 'DDER S %=Y(0),X=Y
  Q
+SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ))
+ I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")=""
+ E  K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")
+ Q
+NKEY W:'$D(ZTQUEUED) "??  Required key field" S X="?BAD" G QS
+KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY")
 BEGIN S DNM="SDXACSE2",DQ=1
-1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="1;1",DV="SI",DU="",DLB="COMPUTER GENERATED?",DIFLD=11
- S DE(DW)="C1^SDXACSE2"
- S DU="1:YES;"
- S X=1
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-C1 G C1S:$D(DE(1))[0 K DB S X=DE(1),DIC=DIE
- K:X ^SDV("AG",DA(1),DA)
-C1S S X="" Q:DG(DQ)=X  K DB S X=DG(DQ),DIC=DIE
- S:X ^SDV("AG",DA(1),DA)=""
- Q
-X1 Q
-2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X2 I 'SDAPTYPR S Y="@1"
- Q
-3 D:$D(DG)>9 F^DIE17,DE S DQ=3,DW="0;6",DV="S",DU="",DLB="UNRESOLVED APPT TYPE REASON",DIFLD=6
- S DU="1:DUAL ELIGIBILITY;2:POSSIBLE COMP & PEN;"
- S X=SDAPTYPR
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X3 Q
-4 S DQ=5 ;@1
-5 S DW="PR;1",DV="*P81'X",DU="",DLB="PROCEDURE 1",DIFLD=21
- S DU="ICPT("
- S X=$P(SDCPT(SDJ),U,3)
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X5 Q
-6 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=6 D X6 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X6 I $P(SDCPT(SDJ),U,4)']"" S Y="@99"
- Q
-7 S DW="PR;2",DV="*P81'X",DU="",DLB="PROCEDURE 2",DIFLD=22
- S DU="ICPT("
- S X=$P(SDCPT(SDJ),U,4)
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X7 Q
-8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X8 I $P(SDCPT(SDJ),U,5)']"" S Y="@99"
- Q
-9 S DW="PR;3",DV="*P81'X",DU="",DLB="PROCEDURE 3",DIFLD=23
- S DU="ICPT("
- S X=$P(SDCPT(SDJ),U,5)
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X9 Q
-10 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=10 D X10 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X10 I $P(SDCPT(SDJ),U,6)']"" S Y="@99"
- Q
-11 S DW="PR;4",DV="*P81'X",DU="",DLB="PROCEDURE 4",DIFLD=24
- S DU="ICPT("
- S X=$P(SDCPT(SDJ),U,6)
- S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
- G RD:X="@",Z
-X11 Q
-12 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=12 D X12 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17
-X12 I $P(SDCPT(SDJ),U,7)']"" S Y="@99"
- Q
-13 S DW="PR;5",DV="*P81'X",DU="",DLB="PROCEDURE 5",DIFLD=25
+1 S DW="PR;5",DV="*P81'X",DU="",DLB="PROCEDURE 5",DIFLD=25
  S DU="ICPT("
  S X=$P(SDCPT(SDJ),U,7)
  S Y=X
- S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
+ S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)
  G RD:X="@",Z
-X13 Q
-14 S DQ=15 ;@99
-15 G 1^DIE17
+X1 Q
+2 S DQ=3 ;@99
+3 G 1^DIE17
Index: FOIAVistA/tag/r/SURGERY-SR/SROABCH.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROABCH.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROABCH.m	(revision 636)
@@ -1,28 +1,20 @@
-SROABCH ;BIR/MAM - BATCH PRINT ASSESSMENTS ;11/28/07
- ;;3.0; Surgery ;**77,166**;24 Jun 93;Build 6
+SROABCH ;B'HAM ISC/MAM - BATCH PRINT ASSESSMENTS ; [ 01/08/98   9:54 AM ]
+ ;;3.0; Surgery ;**77**;24 Jun 93
 DATE ; get dates
- S (SRSOUT,SRSP)=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"date of operation within the date range selected.",!
+ S SRSOUT=0 W @IOF,!!,"This report will print all completed or transmitted assessments that have a",!,"'date completed' within the date range selected.",!
  D DATE^SROUTL(.SRASTDT,.SRAENDT,.SRSOUT) G:SRSOUT END
- D SPEC
  W !!,"Depending on the date range entered, this report may be very long.  You should",!,"QUEUE this report to the selected printer.",!
  K %ZIS,IOP,POP,IO("Q") S %ZIS="Q",%ZIS("A")="Print on which Device: " D ^%ZIS S:POP SRSOUT=1 G:POP END
- I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROABCH",(ZTSAVE("SRSITE*"),ZTSAVE("SRASTDT"),ZTSAVE("SRAENDT"),ZTSAVE("SRSP"))="",ZTDESC="Batch Print Risk Assessments" D ^%ZTLOAD S SRSOUT=1 G END
+ I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROABCH",(ZTSAVE("SRSITE*"),ZTSAVE("SRASTDT"),ZTSAVE("SRAENDT"))="",ZTDESC="Batch Print Risk Assessments" D ^%ZTLOAD S SRSOUT=1 G END
 EN ; entry when queued
  S SRSOUT=0,SRABATCH=1
  U IO S SRAENDT=SRAENDT+.9999,SDATE=SRASTDT-.0001 F  S SDATE=$O(^SRF("AC",SDATE)) Q:'SDATE!(SDATE>SRAENDT)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SDATE,SRTN)) Q:'SRTN!SRSOUT  D STUFF
 END I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
+ I $E(IOST)'="P",'SRSOUT W !!,"Press RETURN to continue  " R X:DTIME
  D ^%ZISC K SRTN W @IOF D ^SRSKILL
  Q
-STUFF ;
- I SRSP,$P(^SRF(SRTN,0),"^",4)'=SRSP Q
- S DATE=$P(^SRF(SRTN,0),"^",9)
+STUFF S DATE=$P(^SRF(SRTN,0),"^",9)
  S SR("RA")=$G(^SRF(SRTN,"RA")),X=$P(SR("RA"),"^") I X'="T",X'="C" Q
  I $P(SR("RA"),"^",6)'="Y" Q
  K SRA D ^SROAPAS
  Q
-SPEC ; select specialty
- W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL surgical specialties ?  ",DIR("B")="YES"
- S DIR("?",1)="Enter YES to print the report for all surgical specialties, or NO to",DIR("?")="print the report for a specific surgical specialty."
- D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- I 'Y W ! K DIC S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC S:Y<0 SRSOUT=1 Q:Y<0  S SRSP=+Y
- Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROACAR.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACAR.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACAR.m	(revision 636)
@@ -1,15 +1,11 @@
-SROACAR ;BIR/MAM - OPEATIVE DATA ;12/03/07
- ;;3.0; Surgery ;**38,71,93,95,100,125,142,153,166**;24 Jun 93;Build 6
+SROACAR ;BIR/MAM - OPEATIVE DATA ;03/29/06
+ ;;3.0; Surgery ;**38,71,93,95,100,125,142,153**;24 Jun 93;Build 11
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
  S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
 START D:SRACLR RET G:SRSOUT END S SRACLR=0 K SRA,SRAO D ^SROACR1
-ASK W !,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END
- S X=$S(X="a":"A",X="n":"N",1:X) I '$D(SRAO(X)),(X'?.N1":".N),(X'="A"),(X'="N") D HELP G:SRSOUT END G START
+ASK W !,"Select Operative Information to Edit: " R X:DTIME I '$T!("^"[X) G END
+ S:X="a" X="A" I '$D(SRAO(X)),(X'?.N1":".N),(X'="A") D HELP G:SRSOUT END G START
  I X="A" S X="1:22"
  I X?.N1":".N S Y=$E(X),Z=$P(X,":",2) I Y<1!(Z>22)!(Y>Z) D HELP G:SRSOUT END G START
- I X="N" D  G:SRSOUT END G START
- .W ! K DIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Are you sure you want to set all fields on this page to NO"
- .D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- .I Y D NO2ALL
  D HDR^SROAUTL
  I X?.N1":".N D RANGE G START
@@ -22,7 +18,6 @@
  Q
 HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below."
- W !!,"1. Enter 'A' to update all information.",!!,"2. Enter 'N' to set all fields on this page to NO."
- W !!,"3. Enter a number (1-22) to update the information in that field.  (For",!,"   example, enter '9' to update Valve Repair.)"
- W !!,"4. Enter a range of numbers (1-22) separated by a ':' to enter a range of",!,"   information.  (For example, enter '6:8' to enter Aortic Valve",!,"   Replacement, Mitral Valve Replacement, and Tricuspid Valve Replacement.)"
+ W !!,"1. Enter 'A' to update all information.",!!,"2. Enter a number (1-22) to update the information in that field.  (For",!,"   example, enter '9' to update Valve Repair.)"
+ W !!,"3. Enter a range of numbers (1-22) separated by a ':' to enter a range of",!,"   information.  (For example, enter '6:8' to enter Aortic Valve",!,"   Replacement, Mitral Valve Replacement, and Tricuspid Valve Replacement.)"
  D RET
  Q
@@ -37,11 +32,4 @@
  I 'SRSOUT,EMILY=12!(EMILY=13) D OK
  Q
-NO2ALL ; set all fields to NO
- N II K DR,DIE S DA=SRTN,DIE=130
- F II=367,368,369,371,481,483,376,380,378,377,379,373,372,505,502 S DR=$S($D(DR):DR_";",1:"")_II_"////N"
- F II=365,366,464,465,416 S DR=DR_";"_II_"////0"
- S DR=DR_";"_370_"////5"_";"_512_"////N"
- D ^DIE K DR
- Q
 OK N SRISCH,SRCPB S X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
  I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! D RET W !
Index: FOIAVistA/tag/r/SURGERY-SR/SROACMP.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACMP.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACMP.m	(revision 636)
@@ -1,4 +1,4 @@
-SROACMP ;BIR/ADM - M&M VERIFICATION REPORT ;12/19/07
- ;;3.0; Surgery ;**47,50,127,143,166**;24 Jun 93;Build 6
+SROACMP ;BIR/ADM-M&M Verification Report ;02/20/05
+ ;;3.0; Surgery ;**47,50,127,143**;24 Jun 93
  S DFN=0 F  S DFN=$O(^TMP("SR",$J,DFN)) Q:'DFN  S SRTN=0 F  S SRTN=$O(^TMP("SR",$J,DFN,SRTN)) Q:'SRTN  D UTIL
  I SRFORM=1,SRSP D SS
@@ -11,5 +11,5 @@
  D HDR2^SROACMP1,END^SROACMP1
  Q
-UTIL ; list all cases within 30 days prior to postop occurrence and/or 90 days prior to death
+UTIL ; list all cases within 90 days prior to postop occurrence and/or death
  S SRPOST=0 F  S SRPOST=$O(^SRF(SRTN,16,SRPOST)) Q:'SRPOST  S SRDATE=$E($P(^SRF(SRTN,16,SRPOST,0),"^",7),1,7) I SRDATE S SRBACK=-30 D PRIOR
  D DEM^VADPT S ^TMP("SRPAT",$J,VADM(1))=DFN_"^"_VA("PID")_"^"_$P(VADM(6),"^")
@@ -25,47 +25,38 @@
  Q
 SET ; set variables to print
- N SRSEP,SRICDN
- S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$P(^SRO(137.45,Y,0),"^")
-OPS S SROPER=$P(^SRF(SRTN,"OP"),"^")
- K SRP,Z S:$L(SROPER)<121 SRP(1)=SROPER I $L(SROPER)>120 S SROPER=SROPER_"  " F M=1:1 D OPER Q:Z=""
- N SRL S SRL=109 D CPTS^SROAUTL0 I SRPROC(1)="" S SRPROC(1)="NOT ENTERED"
+ N SRSEP
+ S SR(0)=^SRF(SRTN,0),(SRD,Y)=$P(SR(0),"^",9),SRSDATE=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3),Y=$P(SR(0),"^",4) I Y S SRSS=$E($P($P(^SRO(137.45,Y,0),"^")," "),1,13),SRSS=$P(SRSS," "),SRSS=$P(SRSS,"(")
+OPS S SROPER=$P(^SRF(SRTN,"OP"),"^"),OPER=0 F  S OPER=$O(^SRF(SRTN,13,OPER)) Q:OPER=""  D OTHER
+ K SRP,Z S:$L(SROPER)<40 SRP(1)=SROPER I $L(SROPER)>39 S SROPER=SROPER_"  " F M=1:1 D OPER Q:Z=""
  S SRCHK=0 I SRDEATH S X1=SRDEATH,X2=-90 D C^%DTC I SRD<X S SRCHK=1,SRREL="N/A"
- I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:"NOT ENTERED")
+ I 'SRCHK S X=$P($G(^SRF(SRTN,.4)),"^",7),SRREL=$S(SRDEATH="":"N/A",X="U":"NO",X="R":"YES",1:" ?")
 COMP ; perioperative occurrences
  K SRC S (SRFG,SRIC)=0 F  S SRIC=$O(^SRF(SRTN,10,SRIC)) Q:SRIC=""  S SRFG=SRFG+1,SRO=^SRF(SRTN,10,SRIC,0),SRICD=$P(SRO,"^",3) D
  .S Y=SRD D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT  S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" "_SRY
  .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)="  ICD: "_$P(SRICDN,"^",2)_"  "_$P(SRICDN,"^",4)
- .S $P(SRC(SRFG),"^",2)="10;"_SRIC
  S SRPC=0 F  S SRPC=$O(^SRF(SRTN,16,SRPC)) Q:SRPC=""  S SRFG=SRFG+1,SRO=^SRF(SRTN,16,SRPC,0),SRICD=$P(SRO,"^",3) D
  .S Y=$E($P(SRO,"^",7),1,7) D DATE S SRCAT=$P(SRO,"^",2) Q:'SRCAT
  .S SRSEP="" I SRCAT=3 S X=$P(SRO,"^",4) I X S SRSEP="/"_$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")_" "
- .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_"  ** POSTOP ** "_SRSEP_SRY
+ .S SRC(SRFG)=$P(^SRO(136.5,SRCAT,0),"^")_" * "_SRSEP_SRY
  .I $P(SRO,"^",2)=3 S X=$P(SRO,"^",4) I X S SRSEP=$S(X=2:"SEPSIS",X=3:"SEPTIC SHOCK",1:"SIRS")
  .I SRICD S SRICDN=$$ICDDX^ICDCODE(SRICD,$P($G(^SRF(SRTN,0)),"^",9)),SRFG=SRFG+1,SRC(SRFG)="  ICD: "_$P(SRICDN,"^",2)_"  "_$P(SRICDN,"^",4)
- .S $P(SRC(SRFG),"^",2)="16;"_SRPC
 RA ; risk assessment type and status
  S SRA=$G(^SRF(SRTN,"RA")),SRSTATUS=$P(SRA,"^"),SRTYPE=$P(SRA,"^",2),SRYN=$P(SRA,"^",6),SRE=$P(SRA,"^",7) D
- .I SRTYPE="" S SRTYPE="NON-ASSESSED" Q
- .S SRTYPE=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARDIAC",1:"EXCLUDED")
- S SRSTATUS=$S(SRSTATUS="C":"COMPLETE",SRSTATUS="T":"TRANSMITTED",SRSTATUS="I":"INCOMPLETE",1:"N/A")
+ .I SRTYPE="" S SRA="NON-ASSESSED" Q
+ .S SRA=$S(SRTYPE="C":"CARDIAC",SRYN="Y":"NON-CARD",1:"EXCLUDED")_"/"_SRSTATUS
 PRINT ; print case information
  I $Y+8>IOSL D HDR^SROACMP1 I SRSOUT Q
- W !!,SRSDATE,?11,SRTN,?25,SRSS,?80,SRTYPE,?98,SRSTATUS,?116,SRREL
- W !,?11,SRP(1) W:$D(SRP(2)) !,?11,SRP(2)
- W !,?11,"CPT Codes: ",SRPROC(1) W:$D(SRPROC(2)) !,?24,SRPROC(2)
- W !,?11,"Occurrences: " I '$D(SRC(1)) S SRC(1)="NONE ENTERED"
- S SRI=0 F  S SRI=$O(SRC(SRI)) Q:'SRI  D
- .W:SRI>1 ! W ?24,$P(SRC(SRI),"^")
- .I $Y+6>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
- .D TEXT D:SRT WP
- S SRNDTH=$P($G(^SRF(SRTN,205)),"^",3)
- I SRDEATH!SRNDTH D  K SRNDTH
- .I SRNDTH W !,?11,"Date of Death: "_$E(SRNDTH,4,5)_"/"_$E(SRNDTH,6,7)_"/"_$E(SRNDTH,2,3) S X=$E(SRNDTH,9,12) I X S X=X_"000" W "@"_$E(X,1,2)_":"_$E(X,3,4)
- .W !,?11,"Review of Death Comments: " D
- ..I '$O(^SRF(SRTN,47,0)) W "NONE ENTERED" Q
- ..D DWP
+ W !!,SRSDATE,?11,SRSS,?25,SRP(1),?69,SRREL W:$D(SRC(1)) ?75,SRC(1) W ?120,SRA
+ F SRC=2:1 Q:'$D(SRP(SRC))&'$D(SRC(SRC))  D  Q:SRSOUT
+ .I $Y+6>IOSL D HDR^SROACMP1 I SRSOUT Q
+ .W ! W:$D(SRP(SRC)) ?25,SRP(SRC) W:$D(SRC(SRC)) ?75,SRC(SRC)
  Q
-OPER ; break procedure if greater than 48 characters
- S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z=""  Q:$L(SRP(M))+$L(Z)'<49  S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
+OTHER ; other operations
+ S SRLONG=1 I $L(SROPER)+$L($P(^SRF(SRTN,13,OPER,0),"^"))>250 S SRLONG=0,OPER=999,SROPERS=" ..."
+ I SRLONG S SROPERS=$P(^SRF(SRTN,13,OPER,0),"^")
+ S SROPER=SROPER_$S(SROPERS=" ...":SROPERS,1:", "_SROPERS)
+ Q
+OPER ; break procedure if greater than 40 characters
+ S SRP(M)="" F LOOP=1:1 S Z=$P(SROPER," ") Q:Z=""  Q:$L(SRP(M))+$L(Z)'<40  S SRP(M)=SRP(M)_Z_" ",SROPER=$P(SROPER," ",2,200)
  Q
 DATE S SRY=$S(Y:" ("_$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_")",1:" (NO DATE)")
@@ -77,17 +68,2 @@
  S SRNAME="" F  S SRNAME=$O(^TMP("SRPAT",$J,SRNAME)) Q:SRNAME=""  S DFN=$P(^TMP("SRPAT",$J,SRNAME),"^") I '$D(^TMP("SRSP",$J,DFN)) K ^TMP("SR",$J,DFN),^TMP("SRPAT",$J,SRNAME)
  Q
-WP ; print occurrence comments
- N CM K ^UTILITY($J,"W") S CM=0 F  S CM=$O(^SRF(SRTN,SRY,SRZ,1,CM)) Q:'CM  S X=^SRF(SRTN,SRY,SRZ,1,CM,0),DIWL=30,DIWR=132 D ^DIWP
- I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",30) D
- .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
- .W !,?30,^UTILITY($J,"W",30,J,0)
- Q
-TEXT ; check for occurrence comments
- S SRT=0,SRX=$P(SRC(SRI),"^",2) I SRX'="" S SRY=$P(SRX,";"),SRZ=$P(SRX,";",2) I $O(^SRF(SRTN,SRY,SRZ,1,0)) S SRT=1 W !,?26,">>> Comments:"
- Q
-DWP ; print review of death comments
- N CM K ^UTILITY($J,"W") S CM=0 F  S CM=$O(^SRF(SRTN,47,CM)) Q:'CM  S X=^SRF(SRTN,47,CM,0),DIWL=38,DIWR=132 D ^DIWP
- I $D(^UTILITY($J,"W")) F J=1:1:^UTILITY($J,"W",38) D
- .I $Y+7>IOSL D HDR^SROACMP1 W ! I SRSOUT Q
- .W ?38,^UTILITY($J,"W",38,J,0),!
- Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROACMP1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACMP1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACMP1.m	(revision 636)
@@ -1,13 +1,9 @@
-SROACMP1 ;BIR/ADM - M&M VERIFICATION REPORT (CONT'D) ;11/26/07
- ;;3.0; Surgery ;**47,68,77,50,166**;24 Jun 93;Build 6
+SROACMP1 ;BIR/ADM-M&M Verification Report (cont'd) ; [ 09/22/98  11:22 AM ]
+ ;;3.0; Surgery ;**47,68,77,50**;24 Jun 93
 EN ; entry point
- S (SRSOUT,SRSP)=0,SRINST=$P($$SITE^SROVAR,"^",2) W @IOF,!,?28,"M&M Verification Report"
- W !!,"The M&M Verification Report is a tool to assist in the review of occurrences"
- W !,"and their assignment to operations and in the review of death unrelated or",!,"related assignments to operations."
- W !!,"The full report includes all patients who had operations within the selected"
- W !,"date range who experienced intraoperative occurrences, postoperative"
- W !,"occurrences or death within 90 days of surgery. The pre-transmission report"
- W !,"is similar but includes only operations with completed risk assessments that"
- W !,"have not yet transmitted to the national database.",!
+ S (SRSOUT,SRSP)=0,SRINST=$P($$SITE^SROVAR,"^",2) W @IOF,!,?28,"M&M Verification Report",!!,"The M&M Verification Report is a tool to assist in the review of occurrences"
+ W !,"and their assignments to operations and in the review of death unrelated or",!,"related assignments to operations.  Two varieties of this report are available."
+ W !,"The first variety provides a report of all patients who had operations within",!,"the selected date range who experienced introperative occurrences,",!,"postoperative occurrences, or death within 90 days of surgery.  The second"
+ W !,"variety provides a similar report for all risk assessed operations that are in",!,"a completed state but have not yet transmitted to the national database.",!
  D SEL G:SRSOUT END I SRFORM=2 G SPEC
  D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
@@ -38,5 +34,5 @@
  Q
 SEL ; select report version
- K DIR S DIR("A",1)="Print which report ?",DIR("A",2)=" ",DIR("A",3)="1. Full report for selected date range.",DIR("A",4)="2. Pre-transmission report for completed risk assessments."
+ K DIR S DIR("A",1)="Print which variety of the report ?",DIR("A",2)=" ",DIR("A",3)="1. Print full report for selected date range.",DIR("A",4)="2. Print pre-transmission report for completed risk assessments."
  S DIR("A",5)=" ",DIR("A")="Enter selection (1 or 2): ",DIR("B")=1,DIR("?")="Please enter the number (1 or 2) matching your choice of report",DIR(0)="NA^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
  S SRFORM=Y
@@ -52,15 +48,15 @@
  W:$Y @IOF W !,?(132-$L(SRINST)\2),SRINST,?124,"Page ",PAGE,!,?54,"M&M Verification Report"
  W:SRFORM=1 !,?(132-$L(SRFRTO)\2),SRFRTO
- W:SRFORM=2 !,?41,"PRE-TRANSMISSION REPORT FOR COMPLETED ASSESSMENTS"
- W ?100,"REVIEWED BY:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"DATE REVIEWED:",!
- W !,"OP DATE",?11,"CASE #",?25,"SURGICAL SPECIALTY",?80,"ASSESSMENT TYPE   STATUS",?116,"DEATH RELATED",!,?11,"PRINCIPAL PROCEDURE",! F LINE=1:1:132 W "="
+ W:SRFORM=2 !,?41,"Pre-Transmission Report for Completed Assessments"
+ W ?100,"Reviewed By:",!,?(132-$L(SRPRINT)\2),SRPRINT,?100,"Date Reviewed:",!
+ W !,?68,"Death",?120,"Assessment",!,"Op Date",?11,"Specialty",?25,"Procedure(s)",?67,"Related  Occurrence(s) - (Date)",?120,"Type/Status",! F LINE=1:1:132 W "="
  I SRNM W !,SRNAME_"   * * Continued from previous page * *"
  S PAGE=PAGE+1,SRHDR=1 I '$D(^TMP("SR",$J))
  Q
 HDR2 ; more heading
- ;I $Y+6<IOSL F I=$Y:1:IOSL-5 W !
+ I $Y+5<IOSL F I=$Y:1:IOSL-5 W !
 FOOT ; print footer
- ;W ! F LINE=1:1:IOM W "-"
- ;W !,"Occurrences(s): '*' Denotes Postop Occurrence",! F LINE=1:1:IOM W "-"
+ W ! F LINE=1:1:IOM W "-"
+ W !,"Occurrences(s): '*' Denotes Postop Occurrence",?69,"Assessment Status - I:Incomplete, C:Complete, T:Transmitted",! F LINE=1:1:IOM W "-"
  S SRHDR=0 I $E(IOST)'="P" W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S SRSOUT=1
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROACOM.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACOM.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACOM.m	(revision 636)
@@ -1,10 +1,11 @@
-SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;12/19/07
- ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160,166**;24 Jun 93;Build 6
+SROACOM ;BIR/MAM - COMPLETE ASSESSMENT ;02/08/07
+ ;;3.0; Surgery ;**38,55,63,65,88,93,95,102,100,125,134,142,160**;24 Jun 93;Build 7
  I '$D(SRTN) Q
- I $P($G(^SRF(SRTN,"RA")),"^",2)="C" G ^SROACOM1
  S (SRSFLG,SRSOUT,SROVER)=0,SRA=$G(^SRF(SRTN,"RA")),Y=$P(SRA,"^") I Y'="I" W !!,"This assessment has a "_$S(Y="C":"'COMPLETE'",1:"'TRANSMITTED'")_" status.",!!,"No action taken." G END
  I $P(SRA,"^",2)="N",$P(SRA,"^",6)="Y" D CHK^SROAUTL
  I $P(SRA,"^",2)="N",$P(SRA,"^",6)="N" D CHK^SROAUTL3
+ I $P(SRA,"^",2)="C" D CHK^SROAUTLC
  S SRFLD="" I $O(SRX(SRFLD))'="" D LIST
+ I $P(SRA,"^",2)="C" D CHCK G:SRSOUT END
 YEP I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !!,?6,"The coding for Procedure and Diagnosis is not complete."
  W ! S SRFLD="" K DIR S DIR("A")="Are you sure you want to complete this assessment ? ",DIR("B")=$S($O(SRX(SRFLD)):"NO",1:"YES"),DIR(0)="YA"
@@ -28,7 +29,8 @@
 END I 'SRSOUT,$E(IOST)'="P" D RET
  W @IOF I $E(IOST)="P" D ^%ZISC W @IOF
- D ^SRSKILL K SRMD,SRMD1,SRSFLG
+ D ^SRSKILL K SRSFLG
  Q
 LIST W @IOF,!,"This assessment is missing the following items:",! S SRZ="",SRCNT=1
+ ;I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,?6,"The coding for Procedure and Diagnosis is",!,?6,"not complete.",!
  F  S SRZ=$O(SRX(SRZ)) Q:SRZ=""  D:$Y+5>IOSL RET Q:SRSOUT  W !,?5,$J(SRCNT,2)_". "_$P(SRX(SRZ),"^") S SRCNT=SRCNT+1
  S SRSOUT=0 W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to enter the missing items at this time",DIR("B")="NO" D ^DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
@@ -38,8 +40,20 @@
  .I $E(SRMD,1,10)="ANESTHESIA" D ANES Q
  .I $E(SRMD,1,6)="POSTOP"!($E(SRMD,1,6)="SEPSIS") D POST^SROCMPS Q
+ .I SRMD=240 D FUNCT Q
+ .I SRMD=492 D FUNCTI^SROAPRE Q
+ .I SRMD=485 W @IOF,! D PRIOR^SROACL2 K DR,DIE S DA=SRTN,DR="485///"_$S(X="@":"@",1:$P(Y,"^")),DIE=130 D ^DIE K DR S:$D(Y) SRSFLG=1 Q
  .K DR,DIE S DA=SRTN,DIE=130,DR=$S($G(SRMD1):SRMD1,1:SRMD)_"T" D ^DIE K DR I $D(Y) S SRSFLG=1
  S:'$G(SRSOUT) SRSOUT=0
  Q
+FUNCT I $P($G(^SRF(SRTN,"RA")),"^",2)="C" D FUNCT^SROACLN Q
+ D FUNCTJ^SROAPRE
+ Q
 ANES K DR,DIE,DA S DA=SRTN,DR=.37,DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE S:$D(Y) SRSFLG=1 K DR
+ Q
+CHCK ; cardiac checks added by SR*3*93
+ N SRADM,SRDIS,SRISCH,SRCPB,SRRET S SRRET=0,X=$G(^SRF(SRTN,208)),SRADM=$P(X,"^",14),SRDIS=$P(X,"^",15),X=$G(^SRF(SRTN,206)),SRISCH=$P(X,"^",36),SRCPB=$P(X,"^",37)
+ I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***" S SRRET=1,SRX(418)=""
+ I SRISCH,SRCPB,SRISCH>SRCPB W !!,"  ***  NOTE: Ischemic Time is greater than CPB Time!!  Please check.  ***",! S SRRET=1,SRX(450)=""
+ I SRRET W ! K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) SRSOUT=1 W !
  Q
 RET W !! K DIR S DIR(0)="E" D ^DIR K DIR W @IOF I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
Index: FOIAVistA/tag/r/SURGERY-SR/SROACOP.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACOP.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACOP.m	(revision 636)
@@ -1,4 +1,4 @@
-SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;12/20/07
- ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160,166**;24 Jun 93;Build 6
+SROACOP ;BIR/MAM - CARDIAC OPERATIVE RISK SUMMARY ;02/14/07
+ ;;3.0; Surgery ;**38,47,71,88,95,107,100,125,142,153,160**;24 Jun 93;Build 7
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
  N SRCSTAT S SRACLR=0,SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
@@ -8,5 +8,5 @@
  S Y=$P($G(^SRF(SRTN,1.1)),"^",3),C=$P(^DD(130,1.13,0),"^",2) D:Y'="" Y^DIQ S SRAO(2)=Y_"^1.13"
  S SRAO(1)=$P(SRA(206),"^",31)_"^364",SRAO(3)=$P(SRA(208),"^",12)_"^414"
- S (X,Y)=$P(SRA(206),"^",32) D:Y DT S SRAO("1A")=X_"^364.1"
+ S Y=$P(SRA(206),"^",32) D DT S SRAO("1A")=X_"^364.1"
  S Y=$P(SRAO(3),"^") I Y'="" S C=$P(^DD(130,414,0),"^",2) D Y^DIQ S $P(SRAO(3),"^")=Y
  S Y=$P(SRA(208),"^",13) D DT S SRAO("3A")=X_"^414.1"
@@ -16,6 +16,6 @@
  S SRCSTAT=">> Coding "_$S($P($G(^SRO(136,SRTN,10)),"^"):"",1:"Not ")_"Complete <<"
  S SRPAGE="PAGE: 1" D HDR^SROAUTL S SRAO(7)=""
- S (X,X1)=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X
- S X=$P(SRAO("1A"),"^") I X1'=""!(X'="") W !,?3," A. Date/Time Collected:    "_X
+ S X=$P(SRAO(1),"^"),X=$S(X?1.3N:X_"%",1:X) W !," 1. Physician's Preoperative Estimate of Operative Mortality: "_X
+ S X=$P(SRAO("1A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
  W !," 2. ASA Classification:",?31,$P(SRAO(2),"^"),!," 3. Surgical Priority:",?31,$P(SRAO(3),"^")
  S X=$P(SRAO("3A"),"^") I X'="" W !,?3," A. Date/Time Collected:    "_X
@@ -56,8 +56,5 @@
  I EMILY=7 D DISP^SROAUTL0 Q
  K DR,DIE S DA=SRTN,DIE=130,DR=$P(SRAO(EMILY),"^",2)
- S DR=DR_"T",DIE=130 S DR=DR_$S(EMILY=3:";414.1T",1:"") D ^DIE K DR I $D(Y) S SRSOUT=1
- I EMILY=1 D
- .I $P(^SRF(SRTN,206),"^",31)="NS" S $P(^SRF(SRTN,206),"^",32)="NS" Q
- .S DR="364.1T",DIE=130 D ^DIE K DR I $D(Y) S SRSOUT=1
+ S DR=DR_"T",DIE=130 S DR=DR_$S(EMILY=1:";364.1T",EMILY=3:";414.1T",1:"") D ^DIE K DR I $D(Y) S SRSOUT=1
  Q
 RET Q:SRSOUT  W !!,"Press ENTER to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROACPM.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACPM.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACPM.m	(revision 636)
@@ -1,4 +1,4 @@
-SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;12/04/07
- ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164,166**;24 Jun 93;Build 6
+SROACPM ;BIR/ADM - CARDIAC RESOURCE INFO ;08/23/07
+ ;;3.0; Surgery ;**71,93,95,99,100,125,142,160,164**;24 Jun 93;Build 2
  ;
  ; Reference to ^DGPM("APTT1" supported by DBIA #565
@@ -11,7 +11,6 @@
  S DIR("A")="Select Number",DIR(0)="NO^1:2" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
  I Y=1 D PIMS G START
-EDIT N DAYS,HOURS,MINS
- S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N"
- S SRR=0 S SRPAGE="PAGE: 1" D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="418;419;440;.205;.232;470;471;473;472;431;442;513;515"
+EDIT S:$P(^SRF(SRTN,206),"^",41)="" $P(^SRF(SRTN,206),"^",41)="N"
+ S SRR=0 S SRPAGE="PAGE: 1" D HDR^SROAUTL K DR S SRQ=0,(DR,SRDR)="418;419;440;.205;.232;470;471;473;472;431;442;513"
  K DA,DIC,DIQ,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="IE",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
  K SRZ S SRZ=0 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
@@ -35,6 +34,4 @@
 EXT I SRFLD=440&(SREXT="NS") S SREXT=SREXT_"-"_$S(SREXT="NS":"No Study",1:SREXT)
  I SRFLD=470,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains intubated at 30 days",1:SREXT)
- I SRFLD=470,$G(SRY(130,SRTN,470,"I")) D  Q
- .S X=$$FMDIFF^XLFDT(SRY(130,SRTN,470,"I"),SRY(130,SRTN,.232,"I"),2) W ?39,SREXT,!,?10,"Postop Intubation Hrs: "_$FN((X/3600),"+",1)
  I SRFLD=471,(SREXT="NS"!(SREXT="RI")) S SREXT=SREXT_"-"_$S(SREXT="NS":"Unable to determine",SREXT="RI":"Remains in ICU at 30 days",1:SREXT)
  I $L(SREXT)<41 W ?39,SREXT W:SRFLD=247 $S(SREXT="":"",SREXT=1:" Day",SREXT=0:" Days",SREXT>1:" Days",1:"") Q
@@ -44,5 +41,5 @@
  ..F I=0:1:50 S J=51-I,Y=$E(X,J) I Y=" " W ?28,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
  Q
-SEL S SRSOUT=0 W !!,"Select Resource Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+SEL S SRSOUT=0 W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRZ(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
  I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRZ)!(Y>Z) D HELP S SRR=1 Q
@@ -68,7 +65,6 @@
 ONE ; edit one item
  I EMILY=7 D LIST
- I EMILY'=7 K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
+ K DR,DA,DIE S DR=$P(SRZ(EMILY),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(EMILY),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
  I 'SRSOUT,EMILY=1!(EMILY=2) D OK
- I EMILY=12 D CHK
  Q
 OK ; compare admission date to discharge date
@@ -76,21 +72,14 @@
  I SRADM,SRDIS,SRADM'<SRDIS W !!,"  ***  NOTE: Discharge Date precedes Admission Date!!  Please check.  ***",! D PRESS W !
  Q
-CHK ; compare date OF OPERATION to CT Surgery Consult Date
- S X1=$P(^SRF(SRTN,0),"^",9),X2=$P($G(^SRF(SRTN,209)),"^",15) D ^%DTC I X'>30 S $P(^SRF(SRTN,209),"^",16)="N" Q
- S $P(^SRF(SRTN,209),"^",16)="" K DR,DA,DIE S DR=$P(SRZ(13),"^",2)_"T",DA=SRTN,DIE=130,SRDT=$P(SRZ(13),"^",3) S:SRDT DR=DR_";"_SRDT_"T" D ^DIE K DR,DA I $D(Y) S SRSOUT=1
- Q
 LIST ; display list of patient movements
- N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRN,SRT,SRTYPE,SRZ,SRY
+ N CNT,SRADM,SRLOC,SRMOVE,SRMVMT,SRT,SRTYPE,SRZ,SRY
  S DFN=$P(^SRF(SRTN,0),"^"),SRZ=$P($G(^SRF(SRTN,.2)),"^",12)
- S SRADM=0 D ADM
- S CNT=0 F  Q:'SRZ  D:SRZ MVMT
- ;Q:CNT=0
+ S SRADM=0 D ADM Q:'SRZ
+ S CNT=0 F  Q:'SRZ  D MVMT
+ Q:CNT=0
  W !!,?5,"To identify the date and time the patient was discharged from intensive",!,?5,"care following surgery, see the following list of patient movements"
  W !,?5,"that occurred during the inpatient stay associated with this surgery.",!
- S (CNT,SRN)=0 F  S CNT=$O(SRMVMT(CNT)) Q:'CNT  S X=SRMVMT(CNT),SRT=$P(X,"^",2),SRN=SRN+1 W !,$J(SRN,3)_".",?5,$P($P(X,"^"),":",1,2),?25,$P(X,"^",3),?37,$S(SRT=3:"From",1:"To")_": "_$P(X,"^",4)
- I '$O(SRMVMT(0)) W !,?5,">> No postoperative patient movements were found for this patient."
- W ! E  K DIR S DIR("A")="Select patient movement from list",DIR(0)="NO^1:"_SRN_":0" D ^DIR K DIR I Y D  Q
- .S SRT=$P($P(SRMVMT(Y),"^"),":",1,2) K DA,DIE,DR S DA=SRTN,DIE=130,DR="471///"_SRT D ^DIE K DA,DIE,DR
- K DA,DIE,DR S DA=SRTN,DIE=130,DR="471T" D ^DIE K DA,DIE,DR
+ S CNT=0 F  S CNT=$O(SRMVMT(CNT)) Q:'CNT  S X=SRMVMT(CNT),SRT=$P(X,"^",2) W !,?5,$P($P(X,"^"),":",1,2),?25,$P(X,"^",3),?37,$S(SRT=3:"From",1:"To")_": "_$P(X,"^",4)
+ W !
  Q
 MVMT S VAIP("D")=SRZ D IN5^VADPT S SRY=$P(VAIP(3),"^")
@@ -125,3 +114,2 @@
 DGB ;;472^Surg Performed at Non-VA Facility
 EAC ;;513^CT Surgery Consult Date
-EAE ;;515^Cause for Delay for Surgery
Index: FOIAVistA/tag/r/SURGERY-SR/SROACPM1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACPM1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACPM1.m	(revision 636)
@@ -1,4 +1,4 @@
-SROACPM1 ;BIR/SJA - LAB INFO ;01/14/08
- ;;3.0; Surgery ;**125,153,166**;24 Jun 93;Build 6
+SROACPM1 ;BIR/SJA - LAB INFO ;05/04/06
+ ;;3.0; Surgery ;**125,153**;24 Jun 93;Build 11
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
  S SRSOUT=0 D ^SROAUTL
@@ -27,15 +27,15 @@
 RET Q:SRSOUT  W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  Q
-DISP N SRX S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL
- S SRX=$P(SRAO(1),"^") W !," 1. HDL:",?25,$J(SRX,6),?35,$$NORCHK(21,SRX),?38,$P(SRAO(1),"^",2)
- S SRX=$P(SRAO(2),"^") W !," 2. LDL:",?25,$J(SRX,6),?35,$$NORCHK(23,SRX),?38,$P(SRAO(2),"^",2)
- S SRX=$P(SRAO(3),"^") W !," 3. Total Cholesterol:",?25,$J(SRX,6),?35,$$NORCHK(24,SRX),?38,$P(SRAO(3),"^",2)
- S SRX=$P(SRAO(4),"^") W !," 4. Serum Triglyceride:",?25,$J(SRX,6),?35,$$NORCHK(22,SRX),?38,$P(SRAO(4),"^",2)
- S SRX=$P(SRAO(5),"^") W !," 5. Serum Potassium:",?25,$J(SRX,6),?35,$$NORCHK(5,SRX),?38,$P(SRAO(5),"^",2)
- S SRX=$P(SRAO(6),"^") W !," 6. Serum Bilirubin:",?25,$J(SRX,6),?35,$$NORCHK(14,SRX),?38,$P(SRAO(6),"^",2)
- S SRX=$P(SRAO(7),"^") W !," 7. Serum Creatinine:",?25,$J(SRX,6),?35,$$NORCHK(7,SRX),?38,$P(SRAO(7),"^",2)
- S SRX=$P(SRAO(8),"^") W !," 8. Serum Albumin:",?25,$J(SRX,6),?35,$$NORCHK(11,SRX),?38,$P(SRAO(8),"^",2)
- S SRX=$P(SRAO(9),"^") W !," 9. Hemoglobin:",?25,$J(SRX,6),?35,$$NORCHK(1,SRX),?38,$P(SRAO(9),"^",2)
- S SRX=$P(SRAO(10),"^") W !,"10. Hemoglobin A1c:",?25,$J(SRX,6),?35,$$NORCHK(27,SRX),?38,$P(SRAO(10),"^",2)
+DISP S SRPAGE="PAGE: 1",SRHDR(.5)="PREOPERATIVE LABORATORY RESULTS" D HDR^SROAUTL
+ W !," 1. HDL:",?25,$J($P(SRAO(1),"^"),6),?35,$P(SRAO(1),"^",2)
+ W !," 2. LDL:",?25,$J($P(SRAO(2),"^"),6),?35,$P(SRAO(2),"^",2)
+ W !," 3. Total Cholesterol:",?25,$J($P(SRAO(3),"^"),6),?35,$P(SRAO(3),"^",2)
+ W !," 4. Serum Triglyceride:",?25,$J($P(SRAO(4),"^"),6),?35,$P(SRAO(4),"^",2)
+ W !," 5. Serum Potassium:",?25,$J($P(SRAO(5),"^"),6),?35,$P(SRAO(5),"^",2)
+ W !," 6. Serum Bilirubin:",?25,$J($P(SRAO(6),"^"),6),?35,$P(SRAO(6),"^",2)
+ W !," 7. Serum Creatinine:",?25,$J($P(SRAO(7),"^"),6),?35,$P(SRAO(7),"^",2)
+ W !," 8. Serum Albumin:",?25,$J($P(SRAO(8),"^"),6),?35,$P(SRAO(8),"^",2)
+ W !," 9. Hemoglobin:",?25,$J($P(SRAO(9),"^"),6),?35,$P(SRAO(9),"^",2)
+ W !,"10. Hemoglobin A1c:",?25,$J($P(SRAO(10),"^"),6),?35,$P(SRAO(10),"^",2)
  W !! F MOE=1:1:80 W "-"
  Q
@@ -46,9 +46,2 @@
  .K DA,DIE,DR S DA=SRCON,DIE=130,DR=S1_"////"_P1_";"_S2_"////"_P2 D ^DIE K DR
  Q
-NORCHK(SRAT,RESULT) ;
- I RESULT']""!(RESULT="NS") Q ""
- N NODE,LOW,HIGH,SRY
- S SRY="" S:"<>"[$E(RESULT) SRY=$E(RESULT),RESULT=$E(RESULT,2,99)
- S NODE=$G(^SRO(139.2,SRAT,2)),LOW=$P(NODE,"^",2),HIGH=$P(NODE,"^",3) Q:LOW']""!(HIGH']"")
- I SRY'="" Q $S(RESULT<(LOW+.01):"L",((RESULT>(HIGH-.01))&(SRY=">")):"H",1:"")
- Q $S(RESULT<LOW:"L",RESULT>HIGH:"H",1:"")
Index: FOIAVistA/tag/r/SURGERY-SR/SROACR2.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROACR2.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROACR2.m	(revision 636)
@@ -1,4 +1,4 @@
-SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;12/03/07
- ;;3.0; Surgery ;**125,153,160,166**;24 Jun 93;Build 6
+SROACR2 ;BIR/SJA - OPERATIVE DATA, PAGE 2 ;04/12/06
+ ;;3.0; Surgery ;**125,153,160**;24 Jun 93;Build 7
  ;
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
@@ -20,5 +20,5 @@
  S SRSOUT=1 G END
  Q
-SEL S SRSOUT=0 W !!,"Select Cardiac Procedures Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+SEL S SRSOUT=0 W !!,"Select Operative Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  Q:X=""  S:X="a" X="A" I '$D(SRFLG),'$D(SRX(X)),(X'?1.2N1":"1.2N),X'="A" D HELP S SRR=1 Q
  I X?1.2N1":"1.2N S Y=$P(X,":"),Z=$P(X,":",2) I Y<1!(Z>SRX)!(Y>Z) D HELP S SRR=1 Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROALEC.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALEC.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALEC.m	(revision 636)
@@ -1,4 +1,4 @@
-SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;02/04/08
- ;;3.0; Surgery ;**160,166**;24 Jun 93;Build 6
+SROALEC ;BIR/ADM - LIST OF ELIGIBLE CASES ;05/04/07
+ ;;3.0; Surgery ;**160**;24 Jun 93;Build 7
  S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="CASES ELIGIBLE FOR ASSESSMENT" K ^TMP("SRA",$J)
  I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
@@ -19,7 +19,4 @@
  S SRCPLT=$P($G(^SRO(136,SRTN,10)),"^") I SRCPLT,'$$XL^SROAX(SRTN) Q
  S SRA=$G(^SRF(SRTN,"RA"))
- I SRAST=1 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="Y")
- I SRAST=2 Q:'($P(SRA,"^",2)="N"!($P(SRA,"^",2)="C"))!'($P(SRA,"^",6)="N")
- I SRAST=3 Q:$P(SRA,"^",2)'=""
  I SRSP S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED"),^TMP("SRA",$J,SRSS,SRSD,SRTN)=SRA Q
  S ^TMP("SRA",$J,SRSD,SRTN)=SRA
@@ -36,16 +33,13 @@
  Q
 PRINT ; print case info
- N SRDA,SRPROCS,SRSP1,SRY S SRPROCS=""
- I $Y+8>IOSL!SRNEW D PAGE I SRSOUT Q
+ N SRDA,SRPROCS,SRY S SRPROCS=""
+ I $Y+6>IOSL!SRNEW D PAGE I SRSOUT Q
  S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
  I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
- S SRSP1="",X=$P(SRA(0),"^",4) S:X SRSP1=$P(^SRO(137.45,X,0),"^")
  S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
  K SROPS,MM,MMM S:$L(SROPER)<63 SROPS(1)=SROPER I $L(SROPER)>62 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
  S X=$P(SRA,"^"),SRSTATUS=$S(X="T":"TRANSMITTED",X="C":"COMPLETE",X="I":"INCOMPLETE",1:"NO ASSESSMENT"),Y=SRSD D D^DIQ S SRDT=$P(Y,"@")
- I $Y+7>IOSL D PAGE I SRSOUT Q
- W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT,?18,SROPS(1),! D
- .I 'SRSP W $E(SRSP1,1,17) F I=2:1 W:$D(SROPS(I)) ?18,SROPS(I),! I '$D(SROPS(I)) W ! Q
- .I SRSP F I=2:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
+ I $Y+5>IOSL D PAGE I SRSOUT Q
+ W !,SRTN,?18,SRANM_" "_VA("PID"),?53,SRATYPE,?67,SRSTATUS,!,SRDT F I=1:1 Q:'$D(SROPS(I))  W ?18,SROPS(I),!
  S SRY=$P($G(^SRO(136,SRTN,0)),"^",2) I SRY D CPT S SRPROCS=SRCODE
  S SRDA=0 F  S SRDA=$O(^SRO(136,SRTN,3,SRDA)) Q:'SRDA  S SRY=$P($G(^SRO(136,SRTN,3,SRDA,0)),"^") I SRY D CPT D
@@ -76,5 +70,5 @@
  W:$E(IOST)="P" !,?(80-$L(SRPRINT)\2),SRPRINT
  W !!,?50,"'*' Denotes Eligible CPT Code" I SRSP,SRSS'="" W !,">>> "_SRSS
- W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! W:'SRSP "SURG SPECIALTY",! F LINE=1:1:80 W "="
+ W !!,"CASE #",?18,"PATIENT",?53,"TYPE",?67,"STATUS",!,"OP DATE",?18,"OPERATION(S)",! F LINE=1:1:80 W "="
  S SRHDR=0,SRNEW=0,SRPAGE=SRPAGE+1
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROALM.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALM.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALM.m	(revision 636)
@@ -1,4 +1,4 @@
-SROALM ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;12/05/07
- ;;3.0; Surgery ;**38,50,88,142,153,160,166**;24 Jun 93;Build 6
+SROALM ;BIR/ADM - LIST OF ASSESSMENTS MISSING INFORMATION ;02/08/07
+ ;;3.0; Surgery ;**38,50,88,142,153,160**;24 Jun 93;Build 7
  S (GRAND,SRNEW,SRSOUT,TOT)=0,(SRHDR,SRPAGE)=1,SRTITLE="COMPLETED/TRANSMITTED ASSESSMENTS MISSING INFORMATION" K ^TMP("SRA",$J)
  I SRFLG,SRASP S SRSPEC=$P(^SRO(137.45,SRASP,0),"^")
@@ -40,5 +40,5 @@
  S CNT=1 W !,?5,"Missing information:"
  I '$P($G(^SRO(136,SRTN,10)),"^")!('$P($G(^SRO(136,SRTN,0)),"^",2))!('$P($G(^SRO(136,SRTN,0)),"^",3)) W !,$J(CNT_". ",8),"The final coding for Procedure and Diagnosis is not complete." S CNT=CNT+1
- F  S SRFLD=$O(SRX(SRFLD)) Q:SRFLD=""  D:$Y+5>IOSL PAGE Q:SRSOUT  W !,$J(CNT_". ",8),$P(SRX(SRFLD),":") S CNT=CNT+1
+ F  S SRFLD=$O(SRX(SRFLD)) Q:SRFLD=""  D:$Y+5>IOSL PAGE Q:SRSOUT  W !,$J(CNT_". ",8),SRX(SRFLD) S CNT=CNT+1
  I 'SRSOUT W ! F LINE=1:1:80 W "-"
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROALOG.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALOG.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALOG.m	(revision 636)
@@ -1,25 +1,19 @@
-SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/24/08
- ;;3.0; Surgery ;**38,55,62,77,50,153,160,166**;24 Jun 93;Build 6
- K SRMNA S (SRSOUT,SRFLG,SRSP,SRAST)=0,SRSRT=1
-START G:SRSOUT END W @IOF K DIR S DIR("A",1)="List of Surgery Risk Assessments",DIR("A",2)="",DIR("A",3)="  1. List of Incomplete Assessments"
- S DIR("A",4)="  2. List of Completed Assessments",DIR("A",5)="  3. List of Transmitted Assessments"
- S DIR("A",6)="  4. List of Non-Assessed Major Surgical Cases",DIR("A",7)="  5. List of All Major Surgical Cases"
- S DIR("A",8)="  6. List of All Surgical Cases",DIR("A",9)="  7. List of Completed/Transmitted Assessments Missing Information"
- S DIR("A",10)="  8. List of 1-Liner Cases Missing Information",DIR("A",11)="  9. List of Eligible Cases"
- S DIR("A",12)=" 10. List of Cases With No CPT Codes",DIR("A",13)=" 11. Summary List of Assessed Cases"
- S DIR("A",14)="",DIR("A")="Select the Number of the Report Desired"
- S DIR(0)="NO^1:11" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y S SRSOUT=1 G END
+SROALOG ;BIR/MAM - ASSESSMENT LOG ;01/22/07
+ ;;3.0; Surgery ;**38,55,62,77,50,153,160**;24 Jun 93;Build 7
+ K SRMNA S (SRSOUT,SRFLG,SRSP)=0
+START G:SRSOUT END W @IOF,!,"List of Surgery Risk Assessments",!!,"  1. List of Incomplete Assessments"
+ W !,"  2. List of Completed Assessments",!,"  3. List of Transmitted Assessments"
+ W !,"  4. List of Non-Assessed Major Surgical Cases",!,"  5. List of All Major Surgical Cases"
+ W !,"  6. List of All Surgical Cases",!,"  7. List of Completed/Transmitted Assessments Missing Information"
+ W !,"  8. List of 1-Liner Cases Missing Information",!,"  9. List of Eligible Cases"
+ W !!,"Select the Number of the Report Desired: " R X:DTIME I '$T!("^"[X) S SRSOUT=1 G END
+ I X<1!(X>9)!(X\1'=X) D HELP G START
  S SREPORT=X
-DATE I SREPORT=3 D DSORT G:SRSOUT END
- D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
- I SREPORT=9 D TYPE9 I SRSOUT G END
- I SREPORT=3 D TYPE3 I SRSOUT G END
+DATE D DATE^SROUTL(.SRSD,.SRED,.SRSOUT) G:SRSOUT END
  D SEL G:SRSOUT END
  N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,"^"),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,"^",2))
  I SREPORT<7 W @IOF,!,"This report is designed to print to your terminal screen or a printer. When",!,"using a printer, a 132 column format is used.",!
  K IOP,%ZIS,POP,IO("Q") S %ZIS("A")="Print the List of Assessments to which Device: ",%ZIS="QM" D ^%ZIS I POP S SRSOUT=1 G END
- I $D(IO("Q")) K IO("Q") D  S ZTREQ="@" D ^%ZTLOAD G END
- .S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments"
- .S (ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"),ZTSAVE("SRAST"),ZTSAVE("SRSRT"))=""
+ I $D(IO("Q")) K IO("Q") S ZTRTN="EN^SROALOG",ZTDESC="List of Surgery Risk Assessments",(ZTSAVE("SRSD"),ZTSAVE("SRED"),ZTSAVE("SREPORT"),ZTSAVE("SRASP"),ZTSAVE("SRFLG"),ZTSAVE("SRSP"),ZTSAVE("SRINSTP"))="",ZTREQ="@" D ^%ZTLOAD G END
 EN ; entry when queued
  N SRFRTO S Y=SRSD X ^DD("DD") S SRFRTO="FROM: "_Y_"  TO: ",Y=SRED X ^DD("DD") S SRFRTO=SRFRTO_Y
@@ -34,38 +28,18 @@
  I SREPORT=8 D ^SROALMN G END
  I SREPORT=9 D ^SROALEC G END
- I SREPORT=10 D ^SROALNC G END
- I SREPORT=11 D ^SROALSL G END
  D:SRSP ^SROALSS D:'SRSP ^SROALST
-END I 'SRSOUT,$E(IOST)'="P" W !!,"Press ENTER to continue  " R X:DTIME
+END I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue  " R X:DTIME
  W:$E(IOST)="P" @IOF K ^TMP("SRA",$J) I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
- D ^%ZISC K SRTN,SRAST,SRSRT W @IOF D ^SRSKILL
+ D ^%ZISC K SRTN W @IOF D ^SRSKILL
  Q
-TYPE3 ; select type of eligible cases
- W ! K DIR S DIR("A",1)="Print which Transmitted Cases ?",DIR("A",2)="",DIR("A",3)="   1. Assessed Cases Only"
- S DIR("A",4)="   2. Excluded Cases Only",DIR("A",5)="   3. Both Assessed and Excluded",DIR("A",6)=""
- S DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:3" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
- S SRAST=Y
- Q
-TYPE9 ; select type of transmitted case
- W ! K DIR S DIR("A",1)="Print which Eligible Cases ?",DIR("A",2)="",DIR("A",3)="   1. Assessed Cases Only"
- S DIR("A",4)="   2. Excluded Cases Only",DIR("A",5)="   3. Non-Assessed Cases only",DIR("A",6)="   4. All Cases",DIR("A",7)=""
- S DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:4" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
- S SRAST=Y
- Q
-DSORT ; sort by op date or transmit date
- W ! K DIR S DIR("A",1)="Print by Date of Operation or by Date of Transmission ?",DIR("A",2)="",DIR("A",3)="   1. Date of Operation"
- S DIR("A",4)="   2. Date of Transmission",DIR("A",5)="",DIR("A")="Select Number",DIR("B")=1,DIR(0)="N^1:2"
- D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1
- S SRSRT=Y
+HELP W !!,"Select the number corresponding to the type of report you want to print.",!!,"Press <RET> to continue  " R X:DTIME I '$T!(X["^") S SRSOUT=1
  Q
 SEL ; select specialty
- W ! K DIR S DIR(0)="YA",DIR("A")="Print by Surgical Specialty ?  ",DIR("B")="YES"
- S DIR("?",1)="Enter YES to print the report by surgical specialty, or NO to print",DIR("?")="the report listing all surgical cases."
- D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- Q:'Y
-SEL1 S SRSP=1 W ! K DIR S DIR(0)="YA",DIR("A")="Print report for ALL specialties ?  ",DIR("B")="YES"
- S DIR("?",1)="Enter YES to print the report for all surgical specialties, or NO to",DIR("?")="print the report for a specific surgical specialty."
- D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S SRSOUT=1 Q
- I 'Y W ! S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC I Y>0 S SRASP=+Y,SRFLG=1 Q
+ W !!,"Print by Surgical Specialty ?  YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q
+ S X=$E(X) I "YyNn"'[X W !!,"Enter <RET> to print the report by surgical specialty, or 'N' to print",!,"the report listing all surgical cases." G SEL
+ Q:"Yy"'[X
+SEL1 S SRSP=1 W !!,"Print report for ALL specialties ?  YES// " R X:DTIME S:'$T X="^" I X="^" S SRSOUT=1 Q
+ S X=$E(X) I "YyNn"'[X W !!,"Enter <RET> to print the report for all surgical specialties, or 'N' to ",!,"print the report for a specific surgical specialty." G SEL1
+ I "Yy"'[X W ! S DIC("S")="I '$P(^(0),""^"",3)",DIC("A")="Print the Report for which Surgical Specialty: ",DIC=137.45,DIC(0)="QEAMZ" D ^DIC K DIC I Y>0 S SRASP=+Y,SRFLG=1 Q
  I Y'>0 S SRSOUT=1 Q
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROALT.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALT.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALT.m	(revision 636)
@@ -1,30 +1,21 @@
-SROALT ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08
- ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 6
- S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO
+SROALT ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07
+ ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7
  I $E(IOST)="P" D ^SROALTP Q
  S SRSOUT=0 D HDR
- I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
- I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
  Q
 SET ; print assessments
- K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
+ K SRCPTT S SRCPTT="NOT ENTERED"
  I $Y+5>IOSL D PAGE I SRSOUT Q
- S SR("RA")=^SRF(SRTN,"RA")
- I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
- I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
- S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
  S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
  I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
  S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
- S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
  K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
  S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
  D TECH^SROPRIN
  S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
- S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
- W !,SRTN,?20,SRANM_" "_VA("PID"),?55,$P(SRSS,"("),!,SRDT,?20,SROPS(1),?55,SRTECH,!,SRAT I $D(SROPS(2)) W ?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3)
- N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W:$D(SROPS(2)) ! W SREX,?20,"CPT Codes: "
+ W !,SRTN,?20,SRANM_" "_VA("PID"),?55,$P(SRSS,"("),!,SRDT,?20,SROPS(1),?55,SRTECH I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3)
+ N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
  F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
  W ! F LINE=1:1:80 W "-"
@@ -40,4 +31,4 @@
 PAGE W !!,"Press <RET> to continue, or '^' to quit  " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  I X["?" W !!,"If you want to continue listing incomplete assessments, enter <RET>.  Enter",!,"'^' to return to the menu." G PAGE
-HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"SURGICAL SPECIALTY",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",!,"TRANSMISSION DATE",! F LINE=1:1:80 W "="
+HDR W @IOF,!,?26,"TRANSMITTED RISK ASSESSMENTS",!,?(80-$L(SRFRTO)\2),SRFRTO,!!,"ASSESSMENT #",?20,"PATIENT",?55,"SURGICAL SPECIALTY",!,"OPERATION DATE",?20,"OPERATION(S)",?55,"ANESTHESIA TECHNIQUE",! F LINE=1:1:80 W "="
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROALTP.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALTP.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALTP.m	(revision 636)
@@ -1,20 +1,13 @@
-SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08
- ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 6
+SROALTP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07
+ ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7
  S SRPAGE=1,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
- I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
- I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D SET
  Q
 SET ; print assessments
- K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
+ K SRCPTT S SRCPTT="NOT ENTERED"
  I $Y+5>IOSL S SRPAGE=SRPAGE+1 D HDR I SRSOUT Q
- S SR("RA")=^SRF(SRTN,"RA")
- I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
- I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
- S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
  S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
  S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F  S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
- S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
  K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
  S SRSS=$P(SRA(0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
@@ -22,7 +15,6 @@
  D TECH^SROPRIN
  S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
- S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
- W !,SRTN,?20,SRANM_" "_VA("PID"),?67,$P(SRSS,"("),?107,SRTECH,!,SRDT,?20,SROPS(1),?107,SRAT I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4)
- N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
+ W !,SRTN,?20,SRANM_" "_VA("PID"),?67,$P(SRSS,"("),?107,SRTECH,!,SRDT,?20,SROPS(1) I $D(SROPS(2)) W !,?20,SROPS(2) I $D(SROPS(3)) W !,?20,SROPS(3) I $D(SROPS(4)) W !,?20,SROPS(4)
+ N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
  F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
  W ! F LINE=1:1:132 W "-"
@@ -40,4 +32,4 @@
  W:$Y @IOF W !,?52,"TRANSMITTED RISK ASSESSMENTS",?120,"PAGE "_SRPAGE,!,?(132-$L(SRINST)\2),SRINST,!,?58,"SURGERY SERVICE",?100,"DATE REVIEWED:"
  W !,?(132-$L(SRFRTO)\2),SRFRTO,?100,"REVIEWED BY:"
- W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",?107,"TRANSMISSION DATE",! F LINE=1:1:132 W "="
+ W !!,"ASSESSMENT #",?20,"PATIENT",?67,"SURGICAL SPECIALTY",?107,"ANESTHESIA TECHNIQUE",!,"OPERATION DATE",?20,"OPERATIVE PROCEDURE(S)",! F LINE=1:1:132 W "="
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROALTS.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALTS.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALTS.m	(revision 636)
@@ -1,11 +1,7 @@
-SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/07/08
- ;;3.0; Surgery ;**38,50,142,153,160,166**;24 Jun 93;Build 6
- S SRFRTO=$S(SRSRT=2:"TRANSMISSION DATES ",1:"OPERATION DATES ")_SRFRTO
+SROALTS ;BIR/MAM - TRANSMITTED ASSESSMENTS ;01/18/07
+ ;;3.0; Surgery ;**38,50,142,153,160**;24 Jun 93;Build 7
  I $E(IOST)="P" D ^SROALTSP Q
  S SRSOUT=0 D HDR
- I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
- I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
  S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT  D SS S SRTN=0 F J=0:0 S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT  D SET
  I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
@@ -14,24 +10,19 @@
  I SRFLG,$P(^SRF(SRTN,0),"^",4)'=SRASP Q
  S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
- S SR("RA")=^SRF(SRTN,"RA")
- I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
- I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
  S ^TMP("SRA",$J,SRSS,SRTN)=""
  Q
 SET ; print assessments
- K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
+ K SRCPTT S SRCPTT="NOT ENTERED"
  I $Y+5>IOSL D PAGE I SRSOUT Q
- S SR("RA")=^SRF(SRTN,"RA")
- S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
+ S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
  S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
  I $L(SRANM)>19 S SRANM=$P(SRANM,",")_","_$E($P(SRANM,",",2))_"."
  S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F I=0:0 S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
- S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
  K SROPS,MM,MMM S:$L(SROPER)<34 SROPS(1)=SROPER I $L(SROPER)>33 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
  D TECH^SROPRIN
  S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
- S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
  W !,SRTN,?20,SRANM_" "_VA("PID"),?55,SRAT,!,SRDT,?20,SROPS(1),?55,SRTECH S SRAO=1 F I=0:0 S SRAO=$O(SROPS(SRAO)) Q:'SRAO  W !,?20,SROPS(SRAO)
- N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
+ N I,SRPROC,SRL S SRL=48 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
  F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
  W ! F LINE=1:1:80 W "-"
Index: FOIAVistA/tag/r/SURGERY-SR/SROALTSP.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROALTSP.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROALTSP.m	(revision 636)
@@ -1,9 +1,6 @@
-SROALTSP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/07/08
- ;;3.0; Surgery ;**32,50,142,153,160,166**;24 Jun 93;Build 6
+SROALTSP ;BIR/MAM - TRANSMITTED ASSESSMENTS (PRINTER) ;01/18/07
+ ;;3.0; Surgery ;**32,50,142,153,160**;24 Jun 93;Build 7
  K ^TMP("SRA",$J) S SRPAGE=0,(SRSOUT,SRDFN)=0 D HDR Q:SRSOUT
- I SRSRT=2 F  S SRSD=$O(^SRF("AT",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AT",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
- I SRSRT=1 F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  D
- .S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
+ F  S SRSD=$O(^SRF("AC",SRSD)) Q:'SRSD!(SRSD>SRED)!SRSOUT  S SRTN=0 F  S SRTN=$O(^SRF("AC",SRSD,SRTN)) Q:'SRTN!SRSOUT  S SR("RA")=$G(^SRF(SRTN,"RA")) I $P(SR("RA"),"^")="T",$D(^SRF(SRTN,0)),$$MANDIV^SROUTL0(SRINSTP,SRTN) D UTL
  S SRSS="" F  S SRSS=$O(^TMP("SRA",$J,SRSS)) Q:SRSS=""!SRSOUT  D SS S SRTN=0 F  S SRTN=$O(^TMP("SRA",$J,SRSS,SRTN)) Q:'SRTN!SRSOUT  D SET
  I '$D(^TMP("SRA",$J)) W $$NODATA^SROUTL0()
@@ -13,23 +10,18 @@
  S SRSS=$P(^SRF(SRTN,0),"^",4),SRSS=$S(SRSS:$P(^SRO(137.45,SRSS,0),"^"),1:"SPECIALTY NOT ENTERED")
  S TYPE=$P(SR("RA"),"^",2) I SRSS="SPECIALTY NOT ENTERED",TYPE="C" S SRSS="N/A"
- S SR("RA")=^SRF(SRTN,"RA")
- I SRAST=1 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="Y")
- I SRAST=2 Q:'($P(SR("RA"),"^",2)="N"!($P(SR("RA"),"^",2)="C"))!'($P(SR("RA"),"^",6)="N")
  S ^TMP("SRA",$J,SRSS,SRTN)=""
  Q
 SET ; print assessments
- K SRCPTT,SREX S SRCPTT="NOT ENTERED",SREX=""
+ K SRCPTT S SRCPTT="NOT ENTERED"
  I $Y+5>IOSL D HDR I SRSOUT Q
- S SR("RA")=^SRF(SRTN,"RA")
- S SRAT="",Y=$E($P(SR("RA"),"^",8),1,7) S:Y="" Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
+ S SR("RA")=^SRF(SRTN,"RA"),SRAT="",Y=$E($P(SR("RA"),"^",4),1,7) I Y D D^DIQ S SRAT=Y
  S SRA(0)=^SRF(SRTN,0),DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANM=VADM(1),SRASSN=VA("PID") K VADM
  S SROPER=$P(^SRF(SRTN,"OP"),"^") I $O(^SRF(SRTN,13,0)) S SROTHER=0 F  S SROTHER=$O(^SRF(SRTN,13,SROTHER)) Q:'SROTHER  D OTHER
- S X=$P(SR("RA"),"^",2) I X="C" S SROPER="* "_SROPER
+ S X=$P($G(^SRF(SRTN,"RA")),"^",2) I X="C" S SROPER="* "_SROPER
  K SROPS,MM,MMM S:$L(SROPER)<81 SROPS(1)=SROPER I $L(SROPER)>80 S SROPER=SROPER_"  " F M=1:1 D LOOP Q:MMM=""
  D TECH^SROPRIN
  S Y=$P(SRA(0),"^",9) D D^DIQ S SRDT=$P(Y,"@")
- S X=$P(SR("RA"),"^",7) I X'="" S SREX="EXCLUDED"
  W !,SRTN,?20,SRANM_" "_VA("PID"),?67,SRAT,?107,SRTECH,!,SRDT,?20,SROPS(1) S SRAO=1 F  S SRAO=$O(SROPS(SRAO)) Q:'SRAO  W !,?20,SROPS(SRAO)
- N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,SREX,?20,"CPT Codes: "
+ N I,SRPROC,SRL S SRL=100 D CPTS^SROAUTL0 W !,?20,"CPT Codes: "
  F I=1:1 Q:'$D(SRPROC(I))  W:I=1 ?31,SRPROC(I) W:I'=1 !,?31,SRPROC(I)
  D LINE
Index: FOIAVistA/tag/r/SURGERY-SR/SROAMEAS.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAMEAS.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAMEAS.m	(revision 636)
@@ -1,4 +1,4 @@
 SROAMEAS ;BIR/MAM - INPUT TRANSFORMS, HEIGHT & WEIGHT ;03/20/06
- ;;3.0; Surgery ;**38,125,153,166**;24 Jun 93;Build 6
+ ;;3.0; Surgery ;**38,125,153**;24 Jun 93;Build 11
 H Q:'$D(X)  I X'?.N1"C"&(X'?.N1"c"),(+X'=X) K X Q
  I +X=X S X=X+.5\1 I X'>47.9!(X'<86.1) K X Q
@@ -11,6 +11,2 @@
  I X?.N1"K",(X'>22.9!(X'<318.1)) K X
  Q
-HWC ; reject NS entry if the case is cardiac one
- S X=$S(X="ns":"NS",1:X)
- I $P($G(^SRF($S($G(SRTN):SRTN,1:DA),"RA")),"^",2)="C",X="NS" S X=""
- Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROAMIS.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAMIS.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAMIS.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAMIS ;BIR/MAM - ANESTHESIA AMIS REPORT ;11/26/07
- ;;3.0; Surgery ;**22,34,38,77,50,86,166**;24 Jun 93;Build 6
+SROAMIS ;B'HAM ISC/MAM - ANESTHESIA AMIS REPORT ; [ 12/16/98  2:06 PM ]
+ ;;3.0; Surgery ;**22,34,38,77,50,86**;24 Jun 93
 UTL ; set up ^TMP("SROAMIS",$J
  S PRIN=$P($G(^SRF(SRDFN,.3)),"^",8) I PRIN="" S PRIN="O"
@@ -33,7 +33,5 @@
  Q
 EN ; entry for SROAMIS option
- W @IOF,!,"Anesthesia AMIS",!!,"This report is no longer available.",!
- K DIR S DIR(0)="E" D ^DIR K DIR D END
- Q
+ W @IOF,!,"Anesthesia AMIS",!
 DATE D DATE^SROUTL(.SDATE,.EDATE,.SRSOUT) G:SRSOUT END S SRD=SDATE-.0001
  N SRINSTP S SRINST=$$INST^SROUTL0() G:SRINST="^" END S SRINSTP=$P(SRINST,U),SRINST=$S(SRINST["ALL DIVISIONS":SRINST,1:$P(SRINST,U,2))
Index: FOIAVistA/tag/r/SURGERY-SR/SROAOP.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAOP.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAOP.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAOP ;BIR/MAM - ENTER OPERATION INFO ;11/27/07
- ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160,166**;24 Jun 93;Build 6
+SROAOP ;BIR/MAM - ENTER OPERATION INFO ;04/24/07
+ ;;3.0; Surgery ;**19,38,47,63,67,81,86,97,100,125,142,153,160**;24 Jun 93;Build 7
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
  S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
@@ -65,10 +65,4 @@
  S SROPS(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM=""  Q:$L(SROPS(M))+$L(MM)'<57  S SROPS(M)=SROPS(M)_MM_" ",SROPER=MMM
  Q
-ANES N SRANE,SRNEW
- I $P(SRAO(10),"^")="NOT ENTERED",'$O(^SRF(SRTN,6,0)) D  Q
- .K DIR S DIR("A")="Select ANESTHESIA TECHNIQUE: ",DIR(0)="130.06,.01OA" D ^DIR K DIR S SRANE=Y I $D(DTOUT)!$D(DUOUT)!(Y="") Q
- .K DD,DO S DIC="^SRF(SRTN,6,",X=SRANE,DIC(0)="L" D FILE^DICN K DIC,DD,DO I '+Y Q
- .S SRNEW=+Y
- .K DA,DIE,DR S DA=SRNEW,DA(1)=SRTN,DIE="^SRF(SRTN,6,",DR=".05T;42T" D ^DIE
- K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR
+ANES K DR,DIE,DA S DA=SRTN,DR=".37T",DR(2,130.06)=".01T;.05T;42T",DIE=130 D ^DIE K DR
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPAS.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPAS.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPAS.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ;03/03/08
- ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153,166**;24 Jun 93;Build 6
+SROAPAS ;BIR/MAM - PRINT A COMPLETE ASSESSMENT ; [ 04/13/04  2:50 PM ]
+ ;;3.0; Surgery ;**38,47,81,88,111,112,100,125,153**;24 Jun 93;Build 11
  S SRSOUT=0,SRPG=0,SR("RA")=$G(^SRF(SRTN,"RA")),SRATYPE=$P(SR("RA"),"^",2) F I=200:1:208,200.1 S SRA(I)=$G(^SRF(SRTN,I))
  S SRA("OP")=^SRF(SRTN,"OP"),SRA("CON")=$G(^SRF(SRTN,"CON"))
@@ -48,6 +48,4 @@
  S (X,Z)=SRPTMODT(17) S:X'="" Z=$P(X,"@")_"  "_$E($P(X,"@",2),1,5) W !,"Discharged/Transferred to Chronic Care:",?47,Z
  W !,"In/Out-Patient Status:",?47,$S($P($G(^SRF(SRTN,0)),"^",12)="I":"INPATIENT",$P($G(^SRF(SRTN,0)),"^",12)="O":"OUTPATIENT",1:"")
- S Y=$P($G(^SRF(SRTN,209)),"^",17) X ^DD("DD") W !,"Date Surgery Consult Requested:",?47,Y
- S Y=$P($G(^SRF(SRTN,209)),"^",15) X ^DD("DD") W !,"Surgery Consult Date:",?47,Y
  I $E(IOST)="P" W ! F MOE=1:1:80 W "-"
  I $E(IOST)'="P" D PAGE I SRSOUT G END
@@ -61,5 +59,5 @@
 END Q:$D(SRABATCH)  I 'SRSOUT,$E(IOST)'="P" W !!,"Press <RET> to continue  " R X:DTIME
  W:$E(IOST)="P" @IOF I $D(ZTQUEUED) Q:$G(ZTSTOP)  S ZTREQ="@" Q
- D ^%ZISC K SROETH,SRTN W @IOF D ^SRSKILL
+ D ^%ZISC K SRTN W @IOF D ^SRSKILL
  Q
  ;
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPCA1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPCA1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPCA1.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPCA1 ;BIR/MAM - PRINT CARDIAC CATH INFO ;02/05/08
- ;;3.0; Surgery ;**38,63,71,88,95,125,142,153,166**;24 Jun 93;Build 6
+SROAPCA1 ;BIR/MAM - PRINT CARDIAC CATH INFO ;04/05/04
+ ;;3.0; Surgery ;**38,63,71,88,95,125,142,153**;24 Jun 93;Build 11
  N SRX F I=200:1:202,206,208,209,202.1 S SRA(I)=$G(^SRF(SRTN,I))
  I $Y+14>IOSL D PAGE^SROAPCA I SRSOUT Q
@@ -46,13 +46,12 @@
  S Y=$P($G(^SRF(SRTN,1.1)),"^",3),SRX=1.13,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(208),"^",12),SRX=414,SRAO(3)=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(206),"^",32),SRX=364.1 D DT S SRAO("1A")=X_"^"_SRX
- S Y=$P(SRA(208),"^",13),SRX=414.1 D DT S SRAO("3A")=X_"^"_SRX
- S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22 D DT S SRAO(0)=X_"^"_SRX
- W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") W ?40,"(Operation Began: "_X_")"
- W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) D DT W ?40,"(Operation Ended: "_X_")"
+ S Y=$P(SRA(206),"^",32),SRX=364.1,SRAO("1A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(208),"^",13),SRX=414.1,SRAO("3A")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,.2)),"^",2),SRX=.22,SRAO(0)=$$OUT(SRX,Y)_"^"_SRX
+ W !!,"V. OPERATIVE RISK SUMMARY DATA" S X=$P(SRAO(0),"^") I X'="" W ?40,"(Operation Began: "_X_")"
+ W !,?5,"Physician's Preoperative" S Y=$P($G(^SRF(SRTN,.2)),"^",3) I Y'="" D DT W ?40,"(Operation Ended: "_X_")"
  W !,?7,"Estimate of Operative Mortality: "_$P(SRAO(1),"^") I $P(SRAO(1),"^")'=""&($P(SRAO(1),"^")'="NS") W "%"
  S X=$P(SRAO("1A"),"^") I X'="" W ?57,"("_X_")"
- W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^")
- S X=$P(SRAO(3),"^") W !,?5,"Surgical Priority:",?($S($L(X)>10:24,1:35)),X S X=$P(SRAO("3A"),"^") I X'="" W ?57,"("_X_")"
+ W !,?5,"ASA Classification:",?35,$P(SRAO(2),"^"),!,?5,"Surgical Priority:",?35,$P(SRAO(3),"^") S X=$P(SRAO("3A"),"^") I X'="" W ?57,"("_X_")"
  S X=$P($G(^SRO(136,SRTN,0)),"^",2) I X S Y=$P($$CPT^ICPTCOD(X),"^",2) D SSPRIN^SROCPT0 S X=Y
  S X=$S(X'="":X,1:"CPT Code Missing")
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPCA3.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPCA3.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPCA3.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPCA3 ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;02/05/08
- ;;3.0; Surgery ;**38,71,95,101,125,160,164,166**;24 Jun 93;Build 6
+SROAPCA3 ;B'HAM ISC/MAM - CARDIAC OCCURRENCE DATA ;08/23/07
+ ;;3.0; Surgery ;**38,71,95,101,125,160,164**;24 Jun 93;Build 2
  D EN^SROCCAT K SRA S SRA(205)=$G(^SRF(SRTN,205)),SRA(208)=$G(^SRF(SRTN,208)),SRA(206)=$G(^SRF(SRTN,206)),SRA(209)=$G(^SRF(SRTN,209))
  S NYUK=$P(SRA(208),"^") D YN S SRAO(1)=SHEMP_"^384"
@@ -32,18 +32,15 @@
  S SRA(.2)=$G(^SRF(SRTN,.2))
  W !!,"VIII. RESOURCE DATA"
- S Y=$P(SRA(208),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X
- S Y=$P(SRA(208),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X
+ S Y=$P($G(^SRF(SRTN,208)),"^",14) D DT^SROAPCA1 W !,"Hospital Admission Date:",?47,X
+ S Y=$P($G(^SRF(SRTN,208)),"^",15) D DT^SROAPCA1 W !,"Hospital Discharge Date:",?47,X
  S Y=$P(SRA(.2),"^",10) D DT^SROAPCA1 W !,"Time Patient In  OR: ",?47,X
  S Y=$P(SRA(.2),"^",12) D DT^SROAPCA1 W !,"Time Patient Out OR: ",?47,X
- S Y=$P(SRA(208),"^",22) I Y>1 D DT^SROAPCA1 S Y=X
+ S Y=$P($G(^SRF(SRTN,208)),"^",22) I Y>1 D DT^SROAPCA1 S Y=X
  S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains intubated at 30 days",1:Y) W !,"Date and Time Patient Extubated: ",?47,Y
- I $P(SRA(208),"^",22)>1,$P(SRA(.2),"^",12) D
- .S X=$$FMDIFF^XLFDT($P(SRA(208),"^",22),$P(SRA(.2),"^",12),2) W !,?5,"Postop Intubation Hrs: "_$FN((X/3600),"+",1)
- S Y=$P(SRA(208),"^",23) I Y>1 D DT^SROAPCA1 S Y=X
+ S Y=$P($G(^SRF(SRTN,208)),"^",23) I Y>1 D DT^SROAPCA1 S Y=X
  S Y=$S(Y="NS":"Unable to determine",Y="RI":"Remains in ICU at 30 days",1:Y) W !,"Date and Time Patient Discharged from ICU: ",?47,Y
  S Y=$P(SRA(209),"^") W !,"Patient is Homeless: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"NS",1:"")
  S Y=$P(SRA(206),"^",41) W !,"Cardiac Surg Performed at Non-VA Facility: ",?47,$S(Y="Y":"YES",Y="N":"NO",Y="NS":"UNKNOWN",1:"")
  S Y=$P(SRA(209),"^",15) D DT^SROAPCA1 W !,"CT Surgery Consult Date: ",?47,$P(X," ")
- S Y=$P(SRA(209),"^",16),C=$P(^DD(130,515,0),"^",2) D:Y'="" Y^DIQ W !,"Cause for Delay for Surgery: ",?47,Y
  W !,"Resource Data Comments: "
  I $G(^SRF(SRTN,206.2))'="" S SRQ=0 S X=$G(^SRF(SRTN,206.2)) W:$L(X)<49 X,! I $L(X)>48 S Z=$L(X) D
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPM.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPM.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPM.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPM ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;03/03/08
- ;;3.0; Surgery ;**47,81,111,107,100,125,142,160,166**;24 Jun 93;Build 6
+SROAPM ;BIR/ADM - PATIENT DEMOGRAPHIC INFO ;01/23/07
+ ;;3.0; Surgery ;**47,81,111,107,100,125,142,160**;24 Jun 93;Build 7
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
  S SRSOUT=0,SRSUPCPT=1 D ^SROAUTL
@@ -40,12 +40,7 @@
  I '$G(VADM(12)) W ?40,"UNANSWERED"
  ;
- K DA,DIC,DIQ,DR,SRY S (DR,SRDR)="342;516;513",DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
- S SRZ=12 F M=1:1 S I=$P(SRDR,";",M)  Q:'I  D
- .D TR,GET
- .S SRZ=SRZ+1,Y=$P(X,";;",2),SRFLD=$P(Y,"^"),(Z,SRZ(SRZ))=$P(Y,"^",2)_"^"_SRFLD,SREXT=SRY(130,SRTN,SRFLD,"E")
- .W !,$S($L(SRZ)<2:" "_SRZ,1:SRZ)_". "_$P(Z,"^")_":" D EXT
- ;S SRZ=15,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E") W !,"13. Date/Time of Death:",?40,SREXT
- ;S SRZ(14)="Surgery Consult Date^513",SREXT=SRY(130,SRTN,513,"E") W !,"14. Surgery Consult Date:",?40,SREXT
- ;S SRZ(15)="Date Surgery Consult Requested^516",SREXT=SRY(130,SRTN,516,"E") W !,"15. Date Surgery Consult Requested:",?40,SREXT
+ K DA,DIC,DIQ,DR,SRY S (DR,SRDR)="342",DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="E",DR=SRDR D EN^DIQ1 K DA,DIC,DIQ,DR
+ S SRZ=13,SRZ(13)="Date of Death^342",SREXT=SRY(130,SRTN,342,"E")
+ W !,"13. Date/Time of Death:",?40,SREXT
  K SROL,SROLINE,SRORC,SRORACE,SROLN,SROLN1,SROWRAP,SRNUM1
  ;
@@ -81,5 +76,5 @@
  .F I=0:1:38 S J=39-I,Y=$E(X,J) I Y=" " W ?40,$E(X,1,J-1) S X=$E(X,J+1,$L(X)) Q
  Q
-SEL W !!,"Select Patient Demographics Information to Edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
+SEL W !!,"Select number of item to edit: " R X:DTIME I '$T!(X["^") S SRSOUT=1 Q
  I (X=11)!(X=12) S SRR=1 W !!,"The Patient's Race and Ethnicity information cannot be updated through the" D  Q
  .W !,"Surgery package options."
@@ -98,5 +93,5 @@
  Q
 HELP W @IOF,!!!!,"Enter the number or range of numbers you want to edit.  Examples of proper",!,"responses are listed below.",!!,"NOTE: Items 11 and 12 cannot be updated through the surgery package options."
- W !!,"1. Enter 'A' to update items 1 through 10 and items 13 through 15.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item.  (For example,",!,"   enter '1' to update "_$P(SRZ(1),"^")_")"
+ W !!,"1. Enter 'A' to update items 1 through 10 and item 13.",!!,"2. Enter a number (1-"_SRZ_") to update an individual item.  (For example,",!,"   enter '1' to update "_$P(SRZ(1),"^")_")"
  W !!,"3. Enter a range of numbers (1-"_SRZ_") separated by a ':' to enter a range",!,"   of items.  (For example, enter '1:4' to update items 1, 2, 3 and 4.)",!
  I $D(SRFLG) W !,"4. Enter 'N' or 'NO' to enter negative response for all items.",!!,"5. Enter '@' to delete information from all items.",!
@@ -105,7 +100,5 @@
 RANGE ; range of numbers
  I $$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
- .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) D
- ..I SHEMP<13 F EMILY=SHEMP:1:10,13:1:15 Q:SRSOUT  D ONE
- ..I SHEMP>12 F EMILY=SHEMP:1:15 Q:SRSOUT  D ONE
+ .S SHEMP=$P(X,":"),CURLEY=$P(X,":",2) F EMILY=SHEMP:1:10,13 Q:SRSOUT  D ONE
  Q
 ONE ; edit one item
@@ -130,4 +123,2 @@
 DEC ;;453^Observation Discharge Date/Time
 DED ;;454^Observation Treating Specialty
-EAC ;;513^Surgery Consult Date
-EAF ;;516^Date Surgery Consult Requested
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRE.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRE.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRE.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;11/26/07
- ;;3.0; Surgery ;**38,47,55,88,100,125,142,166**;24 Jun 93;Build 6
+SROAPRE ;BIR/MAM - PREOPERATIVE INFO ;06/03/05
+ ;;3.0; Surgery ;**38,47,55,88,100,125,142**;24 Jun 93
  I '$D(SRTN) W !!,"A Surgery Risk Assessment must be selected prior to using this option.",!!,"Press <RET> to continue  " R X:DTIME G END
  S (SRSOUT,SRACLR)=0,SRSUPCPT=1 D ^SROAUTL,DUP^SROAUTL G:SRSOUT END
@@ -20,13 +20,19 @@
  .I $$LOCK^SROUTL(SRTN) W ! D:EMILY<4 ^SROAPRE1 D:EMILY>3 ^SROAPR1A D UNLOCK^SROUTL(SRTN)
  I $D(SRAO(X)),$$LOCK^SROUTL(SRTN) D  D UNLOCK^SROUTL(SRTN)
- .I X="1H" D FUNCTH Q
+ .I X="1J" D FUNCTI Q
+ .I X="1I" D FUNCTJ Q
  .S SRX=X W ! K DR,DIE S DA=SRTN,DR=$P(SRAO(X),"^",2)_"T",DIE=130 D ^DIE K DR
  G START
 END I '$D(SREQST) W @IOF D ^SRSKILL
  Q
-FUNCTH N X K DA,DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D  Q
+FUNCTI N X K DA,DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D  Q
  .I $D(DTOUT)!$D(DUOUT) Q
  .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
  .K DIE,DR S DIE=130,DR="492////"_Y D ^DIE K DA,DIE,DR
+ Q
+FUNCTJ N X K DA,DIR S DA=SRTN,DIR(0)="130,240",DIR("A")="Functional Health Status Prior to Current Illness" D ^DIR K DIR D  Q
+ .I $D(DTOUT)!$D(DUOUT) Q
+ .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q
+ .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR
  Q
 HELP W @IOF,!!!!,"Enter the number, number/letter combination, or range of numbers you want to",!,"edit.  Examples of proper responses are listed below."
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRE1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRE1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRE1.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRE1 ;BIR/MAM - EDIT PAGE 1 PREOP ;11/26/07
- ;;3.0; Surgery ;**38,47,125,135,141,166**;24 Jun 93;Build 6
+SROAPRE1 ;B'HAM ISC/MAM - EDIT PAGE 1 PREOP ;01/05/05
+ ;;3.0; Surgery ;**38,47,125,135,141**;24 Jun 93
  K DA D @EMILY Q
 1 ; edit general information
@@ -25,6 +25,11 @@
 GEN ; general
  N SRUP S SRUP=""
- W ! K DR,DIE S DA=SRTN,DIE=130,DR="236T;237T;346T;202T;246T;325T;238T" D ^DIE K DIE,DR I $D(Y) Q
- K DIR S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D
+ W ! K DR,DIE S DA=SRTN,DIE=130,DR="236T;237T;346T;202T;202.1T;246T;325T;238T" D ^DIE K DIE,DR I $D(Y) Q
+ K DIR S DA=SRTN,DIR(0)="130,240",DIR("A")="Functional Health Status Prior to Current Illness" D ^DIR K DIR D  Q:SRUP
+ .I $D(DTOUT) Q
+ .I $D(DUOUT) S SRUP=1 Q
+ .I X="@" K DIE,DR S DIE=130,DR="240///@" D ^DIE K DA,DIE,DR Q
+ .K DIE,DR S DIE=130,DR="240////"_Y D ^DIE K DA,DIE,DR
+ S DA=SRTN,DIR(0)="130,492",DIR("A")="Functional Health Status at Evaluation for Surgery" D ^DIR K DIR D
  .I $D(DTOUT)!$D(DUOUT) Q
  .I X="@" K DIE,DR S DIE=130,DR="492///@" D ^DIE K DA,DIE,DR Q
@@ -34,5 +39,5 @@
 NOGEN ; no general problems
  S $P(^SRF(SRTN,200),"^",6)=$S(X="":"",1:1) F I=2,3,4,7 S $P(^SRF(SRTN,200),"^",I)=SRAX
- S $P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1)
+ S $P(^SRF(SRTN,200),"^",8)=$S(X="":"",X="NS":"NS",1:1),$P(^SRF(SRTN,208),"^",9)=$S(X="":"",X="NS":"NS",1:0),$P(^SRF(SRTN,200.1),"^",2)=$S(X="":"",X="NS":"NS",1:1)
  Q
 PULM ; pulmonary
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRE2.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRE2.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRE2.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRE2 ;BIR/MAM - EDIT PAGE 2 PREOP ;11/26/07
- ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 6
+SROAPRE2 ;BIR/MAM - EDIT PAGE 2 PREOP ;06/27/06
+ ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
  D @EMILY Q
 1 ; edit renal information
@@ -31,9 +31,9 @@
  Q
 CNS ; cns
- W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;" D ^DIE K DR,DIE
+ W ! K DR,DIE S DIE=130,DA=SRTN,DR="332T;333T;400T;334T;335T;336T;401T;399T;398T;" D ^DIE K DR,DIE
  S SRACLR=0
  Q
 NOCNS ; no CNS problems
- F I=19,21,24:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX
+ F I=19,21:1:27,29 S $P(^SRF(SRTN,200),"^",I)=SRAX
  Q
 NUT ; nutritional/immune/other
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRT1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRT1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRT1.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRT1 ;BIR/MAM - PREOP INFO (PAGE 1) ;11/28/07
- ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 6
+SROAPRT1 ;BIR/MAM - PREOP INFO (PAGE 1) ;02/23/06
+ ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
  N SRX,Y F I=200,206 S SRA(I)=$G(^SRF(SRTN,I))
  S Y=$P(SRA(200),"^"),SRX=402,SRAO(1)=$$OUT(SRX,Y)_"^"_SRX
@@ -7,8 +7,10 @@
  S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
@@ -30,13 +32,16 @@
  S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX
  W:$E(IOST)="P" ! W !,?28,"PREOPERATIVE INFORMATION",!!
- W "GENERAL:",?31,$P(SRAO(1),"^"),?40,"GASTROINTESTINAL:",?72,$P(SRAO(4),"^")
- W !,"Height: ",?22,$J($P(SRAO("1A"),"^"),15),?40,"Esophageal Varices:",?72,$P(SRAO("4A"),"^")
+ W "GENERAL:",?31,$P(SRAO(1),"^"),?40,"HEPATOBILIARY:",?72,$P(SRAO(3),"^")
+ W !,"Height: ",?22,$J($P(SRAO("1A"),"^"),15),?40,"Ascites:",?72,$P(SRAO("3A"),"^")
  W !,"Weight:",?22,$J($P(SRAO("1B"),"^"),15)
- W !,"Diabetes Mellitus:",?31,$P(SRAO("1C"),"^"),?40,"CARDIAC:",?72,$P(SRAO(5),"^")
- W !,"Current Smoker W/I 1 Year:",?31,$P(SRAO("1D"),"^"),?40,"CHF Within 1 Month:",?72,$P(SRAO("5A"),"^")
- W !,"ETOH > 2 Drinks/Day:",?31,$P(SRAO("1E"),"^"),?40,"MI Within 6 Months:",?72,$P(SRAO("5B"),"^")
- W !,"Dyspnea: ",?13,$J($P(SRAO("1F"),"^"),25),?40,"Previous PCI:",?72,$P(SRAO("5C"),"^")
- W !,"DNR Status: ",?31,$P(SRAO("1G"),"^"),?40,"Previous Cardiac Surgery:",?72,$P(SRAO("5D"),"^")
- W !,"Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?40,"Angina Within 1 Month:",?72,$P(SRAO("5E"),"^")
+ W !,"Diabetes Mellitus:",?31,$P(SRAO("1C"),"^"),?40,"GASTROINTESTINAL:",?72,$P(SRAO(4),"^")
+ W !,"Current Smoker W/I 1 Year:",?31,$P(SRAO("1D"),"^"),?40,"Esophageal Varices:",?72,$P(SRAO("4A"),"^")
+ W !,"Pack/Years:",?31,$P(SRAO("1E"),"^")
+ W !,"ETOH > 2 Drinks/Day:",?31,$P(SRAO("1F"),"^"),?40,"CARDIAC:",?72,$P(SRAO(5),"^")
+ W !,"Dyspnea: ",?13,$J($P(SRAO("1G"),"^"),25),?40,"CHF Within 1 Month:",?72,$P(SRAO("5A"),"^")
+ W !,"DNR Status: ",?31,$P(SRAO("1H"),"^"),?40,"MI Within 6 Months:",?72,$P(SRAO("5B"),"^")
+ W !,"Pre-illness Funct",?40,"Previous PCI:",?72,$P(SRAO("5C"),"^")
+ W !,?12,"Status: ",$J($P(SRAO("1I"),"^"),17),?40,"Previous Cardiac Surgery:",?72,$P(SRAO("5D"),"^")
+ W !,"Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?40,"Angina Within 1 Month:",?72,$P(SRAO("5E"),"^")
  W !,?40,"Hypertension Requiring Meds:",?72,$P(SRAO("5F"),"^")
  W !,"PULMONARY:",?31,$P(SRAO(2),"^")
@@ -44,5 +49,4 @@
  W !,"History of Severe COPD:",?31,$P(SRAO("2B"),"^"),?40,"Revascularization/Amputation:",?72,$P(SRAO("6A"),"^")
  W !,"Current Pneumonia:",?31,$P(SRAO("2C"),"^"),?40,"Rest Pain/Gangrene:",?72,$P(SRAO("6B"),"^")
- W !!,"HEPATOBILIARY:",?31,$P(SRAO(3),"^"),!,"Ascites:",?31,$P(SRAO("3A"),"^")
  Q
 OUT(SRFLD,SRY) ; get data in output form
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRT2.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRT2.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRT2.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRT2 ;BIR/MAM - PRINT PREOP INFO (PAGE 2) ;11/28/07
- ;;3.0; Surgery ;**38,125,137,153,160,166**;24 Jun 93;Build 6
+SROAPRT2 ;BIR/MAM - PRINT PREOP INFO (PAGE 2) ;04/24/07
+ ;;3.0; Surgery ;**38,125,137,153,160**;24 Jun 93;Build 7
  I $E(IOST)'="P" W !,?28,"PREOPERATIVE INFORMATION"
  N SRX,Y S SRA(200)=$G(^SRF(SRTN,200)),SRA(206)=$G(^SRF(SRTN,206))
@@ -10,4 +10,6 @@
  S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
@@ -37,4 +39,6 @@
  W !,"CVA/Stroke w/o Neuro Deficit:",?31,$P(SRAO("2F"),"^"),?40,"Pregnancy:",?(74-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^")
  W !,"Tumor Involving CNS:",?31,$P(SRAO("2G"),"^")
+ W !,"Paraplegia:",?31,$P(SRAO("2H"),"^")
+ W !,"Quadriplegia:",?31,$P(SRAO("2I"),"^")
  I $E(IOST)="P" W !
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRT4.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRT4.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRT4.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRT4 ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;01/14/08
- ;;3.0; Surgery ;**38,125,153,160,166**;24 Jun 93;Build 6
+SROAPRT4 ;BIR/MAM - PRINT ASSESSMENT (CONT.) ;06/28/06
+ ;;3.0; Surgery ;**38,125,153,160**;24 Jun 93;Build 7
  ;K SRA S SRA(201)=$G(^SRF(SRTN,201)),SRA(202)=$G(^SRF(SRTN,202))
  K SRA F I=201,202,203,204,202.1 S SRA(I)=$G(^SRF(SRTN,I))
@@ -7,16 +7,16 @@
  W !,$J("Serum Sodium: ",39) S X=$P(SRA(201),"^") W X S X=$P(SRA(202),"^") I X D DATE W ?48,"("_Y_")"
  W !,$J("Serum Creatinine: ",39) S X=$P(SRA(201),"^",4) W X S X=$P(SRA(202),"^",4) I X D DATE W ?48,"("_Y_")"
- W !,$J("BUN: ",39) S X=$P(SRA(201),"^",5) W X S X=$P(SRA(202),"^",5) I X D DATE W ?48,"("_Y_")"
- W !,$J("Serum Albumin: ",39) S X=$P(SRA(201),"^",8) W X S X=$P(SRA(202),"^",8) I X D DATE W ?48,"("_Y_")"
+ W !,$J("BUN: ",39) S X=$P(SRA(201),"^",5) W X I X S X=$P(SRA(202),"^",5) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Serum Albumin: ",39) S X=$P(SRA(201),"^",8) W X I X S X=$P(SRA(202),"^",8) I X D DATE W ?48,"("_Y_")"
  W !,$J("Total Bilirubin: ",39) S X=$P(SRA(201),"^",9) W X S X=$P(SRA(202),"^",9) I X D DATE W ?48,"("_Y_")"
- W !,$J("SGOT: ",39) S X=$P(SRA(201),"^",11) W X S X=$P(SRA(202),"^",11) I X D DATE W ?48,"("_Y_")"
- W !,$J("Alkaline Phosphatase: ",39) S X=$P(SRA(201),"^",12) W X S X=$P(SRA(202),"^",12) I X D DATE W ?48,"("_Y_")"
+ W !,$J("SGOT: ",39) S X=$P(SRA(201),"^",11) W X I X S X=$P(SRA(202),"^",11) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Alkaline Phosphatase: ",39) S X=$P(SRA(201),"^",12) W X I X S X=$P(SRA(202),"^",12) I X D DATE W ?48,"("_Y_")"
  W !,$J("White Blood Count: ",39) S X=$P(SRA(201),"^",13) W X S X=$P(SRA(202),"^",13) I X D DATE W ?48,"("_Y_")"
- W !,$J("Hematocrit: ",39) S X=$P(SRA(201),"^",14) W X S X=$P(SRA(202),"^",14) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Hematocrit: ",39) S X=$P(SRA(201),"^",14) W X I X S X=$P(SRA(202),"^",14) I X D DATE W ?48,"("_Y_")"
  W !,$J("Platelet Count: ",39) S X=$P(SRA(201),"^",15) W X S X=$P(SRA(202),"^",15) I X D DATE W ?48,"("_Y_")"
  W !,$J("PTT: ",39) S X=$P(SRA(201),"^",16) W X S X=$P(SRA(202),"^",16) I X D DATE W ?48,"("_Y_")"
- W !,$J("PT: ",39) S X=$P(SRA(201),"^",17) W X S X=$P(SRA(202),"^",17) I X D DATE W ?48,"("_Y_")"
- W !,$J("INR: ",39) S X=$P(SRA(201),"^",27) W X S X=$P(SRA(202),"^",27) I X D DATE W ?48,"("_Y_")"
- W !,$J("Hemoglobin A1c: ",39) S X=$P(SRA(201),"^",28) W X S X=$P(SRA(202.1),"^") I X D DATE W ?48,"("_Y_")"
+ W !,$J("PT: ",39) S X=$P(SRA(201),"^",17) W X I X S X=$P(SRA(202),"^",17) I X D DATE W ?48,"("_Y_")"
+ W !,$J("INR: ",39) S X=$P(SRA(201),"^",27) W X I X S X=$P(SRA(202),"^",27) I X D DATE W ?48,"("_Y_")"
+ W !,$J("Hemoglobin A1c: ",39) S X=$P(SRA(201),"^",28) W X I X S X=$P(SRA(202.1),"^") D DATE W ?48,"("_Y_")"
  I $E(IOST)="P" W !!
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPRT5.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPRT5.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPRT5.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPRT5 ;BIR/MAM - PRINT ASSESSMENT (CONT) ;01/14/08
- ;;3.0; Surgery ;**38,88,153,166**;24 Jun 93;Build 6
+SROAPRT5 ;BIR/MAM - PRINT ASSESSMENT (CONT) ;06/28/06
+ ;;3.0; Surgery ;**38,88,153**;24 Jun 93;Build 11
  K SRA S SRA(203)=$G(^SRF(SRTN,203)),SRA(204)=$G(^SRF(SRTN,204))
  W:$E(IOST)="P" ! W !,?22,"POSTOPERATIVE LABORATORY RESULTS",!!,?29," * Highest Value",!,?29,"** Lowest Value"
@@ -9,7 +9,7 @@
  W !,$J("** Potassium: ",39) S X=$P(SRA(203),"^",4) W X S X=$P(SRA(204),"^",4) I X D DATE W ?48,"("_Y_")"
  W !,$J("* Serum Creatinine: ",39) S X=$P(SRA(203),"^",6) W X S X=$P(SRA(204),"^",6) I X D DATE W ?48,"("_Y_")"
- W !,$J("* CPK: ",39) S X=$P(SRA(203),"^",7) W X S X=$P(SRA(204),"^",7) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* CPK: ",39) S X=$P(SRA(203),"^",7) W X I X S X=$P(SRA(204),"^",7) I X D DATE W ?48,"("_Y_")"
  W !,$J("* CPK-MB Band: ",39) S X=$P(SRA(203),"^",8) W X S X=$P(SRA(204),"^",8) I X D DATE W ?48,"("_Y_")"
- W !,$J("* Total Bilirubin: ",39) S X=$P(SRA(203),"^",9) W X S X=$P(SRA(204),"^",9) I X D DATE W ?48,"("_Y_")"
+ W !,$J("* Total Bilirubin: ",39) S X=$P(SRA(203),"^",9) W X I X S X=$P(SRA(204),"^",9) I X D DATE W ?48,"("_Y_")"
  W !,$J("* White Blood Count: ",39) S X=$P(SRA(203),"^",10) W X S X=$P(SRA(204),"^",10) I X D DATE W ?48,"("_Y_")"
  W !,$J("** Hematocrit: ",39) S X=$P(SRA(203),"^",12) W X S X=$P(SRA(204),"^",12) I X D DATE W ?48,"("_Y_")"
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPS1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPS1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPS1.m	(revision 636)
@@ -1,7 +1,4 @@
-SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;12/12/07
- ;;3.0; Surgery ;**38,47,125,153,166**;24 Jun 93;Build 6
- ;
- ; Reference to EN1^GMRVUT0 supported by DBIA #1446
- ;
+SROAPS1 ;BIR/MAM - PREOP INFO (PAGE 1) ;06/08/06
+ ;;3.0; Surgery ;**38,47,125,153**;24 Jun 93;Build 11
  N I S SRPAGE="PAGE: 1 OF 2" D HDR^SROAUTL,PRE1
  W ! F I=1:1:80 W "-"
@@ -13,8 +10,10 @@
  S Y=$P(SRA(200),"^",2),SRX=346,SRAO("1C")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",3),SRX=202,SRAO("1D")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
- S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,208)),"^",9),SRX=202.1,SRAO("1E")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",4),SRX=246,SRAO("1F")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",6),SRX=325,SRAO("1G")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",7),SRX=238,SRAO("1H")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",8),SRX=240,SRAO("1I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P($G(^SRF(SRTN,200.1)),"^",2),SRX=492,SRAO("1J")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",9),SRX=241,SRAO(2)=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",10),SRX=204,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
@@ -35,14 +34,16 @@
  S Y=$P(SRA(200),"^",41),SRX=329,SRAO("6A")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",42),SRX=330,SRAO("6B")=$$OUT(SRX,Y)_"^"_SRX K SRA
- W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^")
- W !,"  A. Height:" S Y=$P(SRAO("1A"),"^") W:Y'="NS" ?14,$J($P(Y,"^"),25) W:Y="NS" ?32,Y
- W ?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^")
+ W "1. GENERAL:",?32,$P(SRAO(1),"^"),?41,"3. HEPATOBILIARY:",?76,$P(SRAO(3),"^")
+ W !,"  A. Height:" S Y=$P(SRAO("1A"),"^") W ?($S(Y="NS":19,1:24)),$J($P(Y,"^"),15),?43,"A. Ascites:",?76,$P(SRAO("3A"),"^")
  W !,"  B. Weight:" S Y=$P(SRAO("1B"),"^") W ?($S(Y="NS":19,1:24)),$J(Y,15)
- W !,"  C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^")
- W !,"  D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^")
- W !,"  E. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1E"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^")
- W !,"  F. Dyspnea: ",?14,$J($P(SRAO("1F"),"^"),25),?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^")
- W !,"  G. DNR Status: ",?32,$P(SRAO("1G"),"^"),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^")
- W !,"  H. Preop Funct Status: ",$J($P(SRAO("1H"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^")
+ W !,"  C. Diabetes Mellitus:",?32,$P(SRAO("1C"),"^"),?41,"4. GASTROINTESTINAL:",?76,$P(SRAO(4),"^")
+ W !,"  D. Current Smoker W/I 1 Year:",?32,$P(SRAO("1D"),"^"),?43,"A. Esophageal Varices:",?76,$P(SRAO("4A"),"^")
+ W !,"  E. Pack/Years:",?32,$P(SRAO("1E"),"^")
+ W !,"  F. ETOH > 2 Drinks/Day:",?32,$P(SRAO("1F"),"^"),?41,"5. CARDIAC:",?76,$P(SRAO(5),"^")
+ W !,"  G. Dyspnea: ",?14,$J($P(SRAO("1G"),"^"),25),?43,"A. CHF Within 1 Month:",?76,$P(SRAO("5A"),"^")
+ W !,"  H. DNR Status: ",?32,$P(SRAO("1H"),"^"),?43,"B. MI Within 6 Months:",?76,$P(SRAO("5B"),"^")
+ W !,"  I. Pre-illness Funct",?43,"C. Previous PCI:",?76,$P(SRAO("5C"),"^")
+ W !,?17,"Status: ",$J($P(SRAO("1I"),"^"),17),?43,"D. Previous Cardiac Surgery:",?76,$P(SRAO("5D"),"^")
+ W !,"  J. Preop Funct Status: ",$J($P(SRAO("1J"),"^"),17),?43,"E. Angina Within 1 Month:",?76,$P(SRAO("5E"),"^")
  W !,?43,"F. Hypertension Requiring Meds:",?76,$P(SRAO("5F"),"^")
  W !,"2. PULMONARY:",?32,$P(SRAO(2),"^")
@@ -50,13 +51,11 @@
  W !,"  B. History of Severe COPD:",?32,$P(SRAO("2B"),"^"),?43,"A. Revascularization/Amputation:",?76,$P(SRAO("6A"),"^")
  W !,"  C. Current Pneumonia:",?32,$P(SRAO("2C"),"^"),?43,"B. Rest Pain/Gangrene:",?76,$P(SRAO("6B"),"^")
- W !!,"3. HEPATOBILIARY:",?32,$P(SRAO(3),"^"),!,"  A. Ascites:",?32,$P(SRAO("3A"),"^")
  Q
 OUT(SRFLD,SRY) ; get data in output form
- N C,Y,Z
+ N C,Y
  S Y=SRY,C=$P(^DD(130,SRFLD,0),"^",2) D:Y'="" Y^DIQ
  I Y="NO STUDY" S Y="NS"
- I SRFLD=237!(SRFLD=346) S Y=$E(Y,1,15)
- I SRFLD=236 S Z=$P($G(^SRF(SRTN,200.1)),"^",7) I Z'="" S Y="("_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Z,2,3)_")  "_Y
- I SRFLD=492 D
+ I SRFLD=236!(SRFLD=237)!(SRFLD=346) S Y=$E(Y,1,15)
+ I SRFLD=240!(SRFLD=492) D
  .I SRY=2 S Y="PARTIAL DEPENDENT" Q
  .I SRY=1 S Y=Y_"    " Q
@@ -65,17 +64,10 @@
  Q Y
 HW ; get weight & height from Vitals
- N SREND,SREQ,SREX,SREY,SRSTRT
+ N SREND,SREX,SRSTRT
 WT I $P($G(^SRF(SRTN,206)),"^",2)="" D
  .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-30),SREX=$$HW^SROACL1(SRSTRT,SREND,"WT")
- .I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,237,"E",SREX,.SREY) I SREY'="^" S $P(^SRF(SRTN,206),"^",2)=SREY
-HT I $P($G(^SRF(SRTN,206)),"^")'="" Q
- N GMRVSTR,SRBRDT,SRBIEN,SRBDATA,SRHTDT
- K ^UTILITY($J,"GMRVD"),RESULTS S SREND=$P($G(^SRF(SRTN,0)),"^",9),GMRVSTR="HT",GMRVSTR(0)="^"_SREND_"^^0"
- D EN1^GMRVUT0 Q:'$D(^UTILITY($J,"GMRVD"))
- S SRBRDT="",SRBRDT=$O(^UTILITY($J,"GMRVD","HT",SRBRDT)) Q:'SRBRDT  D
- .S SRBIEN=0 F  S SRBIEN=$O(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)) Q:'SRBIEN  D
- ..S SRBDATA=$G(^UTILITY($J,"GMRVD","HT",SRBRDT,SRBIEN)),SREX=$P(SRBDATA,"^",8)
- ..I SREX'="" S SREX=SREX+.5\1 D CHK^DIE(130,236,"E",SREX,.SREY) I SREY'="^" D
- ...S $P(^SRF(SRTN,206),"^")=SREY
- ...S SRHTDT=$P(SRBDATA,"^") I SRHTDT'="" S $P(^SRF(SRTN,200.1),"^",7)=SRHTDT
+ .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^",2)=SREX
+HT I $P($G(^SRF(SRTN,206)),"^")="" D
+ .S SREND=$P($G(^SRF(SRTN,0)),"^",9),SRSTRT=$$FMADD^XLFDT(SREND,-365),SREX=$$HW^SROACL1(SRSTRT,SREND,"HT")
+ .I SREX'="" S SREX=SREX+.5\1,$P(^SRF(SRTN,206),"^")=SREX
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROAPS2.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAPS2.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAPS2.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;11/26/07
- ;;3.0; Surgery ;**38,47,125,153,160,166**;24 Jun 93;Build 6
+SROAPS2 ;BIR/MAM - PREOP INFO (PAGE 2) ;04/24/07
+ ;;3.0; Surgery ;**38,47,125,153,160**;24 Jun 93;Build 7
  S SRPAGE="PAGE: 2 OF 2" D HDR^SROAUTL,PRE2
  W !! F I=1:1:80 W "-"
@@ -13,4 +13,6 @@
  S Y=$P(SRA(200),"^",19),SRX=332,SRAO("2A")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",21),SRX=333,SRAO("2B")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",22),SRX=398,SRAO("2I")=$$OUT(SRX,Y)_"^"_SRX
+ S Y=$P(SRA(200),"^",23),SRX=399,SRAO("2H")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",24),SRX=400,SRAO("2C")=$$OUT(SRX,Y)_"^"_SRX
  S Y=$P(SRA(200),"^",25),SRX=334,SRAO("2D")=$$OUT(SRX,Y)_"^"_SRX
@@ -40,4 +42,6 @@
  W !,"  F. CVA/Stroke w/o Neuro Deficit:",?(38-$L($P(SRAO("2F"),"^"))),$P(SRAO("2F"),"^"),?40,"  J. Pregnancy:",?(79-$L($P(SRAO("3J"),"^"))),$P(SRAO("3J"),"^")
  W !,"  G. Tumor Involving CNS:",?(38-$L($P(SRAO("2G"),"^"))),$P(SRAO("2G"),"^")
+ W !,"  H. Paraplegia:",?(38-$L($P(SRAO("2H"),"^"))),$P(SRAO("2H"),"^")
+ W !,"  I. Quadriplegia:",?(38-$L($P(SRAO("2I"),"^"))),$P(SRAO("2I"),"^")
  Q
 OUT(SRFLD,SRY) ; get data in output form
Index: FOIAVistA/tag/r/SURGERY-SR/SROASS.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROASS.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROASS.m	(revision 636)
@@ -1,4 +1,4 @@
 SROASS ;BIR/MAM - SELECT ASSESSMENT ;01/18/07
- ;;3.0; Surgery ;**38,47,64,94,121,100,160,166**;24 Jun 93;Build 6
+ ;;3.0; Surgery ;**38,47,64,94,121,100,160**;24 Jun 93;Build 7
 PST K:$D(DUZ("SAV")) SRNEW K SRTN W !! S SRSOUT=0
  N SRSEL D ^SROPSEL G:'$D(DFN) END S SRANM=VADM(1)_"  "_VA("PID")
@@ -26,5 +26,5 @@
  S:X="" X=1 I X<1!(X>3)!(X'?.N) D HELP G ENTER
  I X=2 D ^SROADEL W !!,"Press <RET> to continue  " R X:DTIME W @IOF K SRTN G END
- I X=3 D @($S($P(SR("RA"),"^",2)="C":"^SROACOM1",1:"^SROACOM")) K SRTN G END
+ I X=3 D ^SROACOM K SRTN G END
  Q
 EXCL I $P($G(^SRO(136,SRTN,10)),"^"),'$$XL^SROAX(SRTN) D
Index: FOIAVistA/tag/r/SURGERY-SR/SROASSP.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROASSP.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROASSP.m	(revision 636)
@@ -1,4 +1,4 @@
-SROASSP ;BIR/MAM - PRINT A COMPLETED ASSESSMENT ;12/05/07
- ;;3.0; Surgery ;**38,94,166**;24 Jun 93;Build 6
+SROASSP ;B'HAM ISC/MAM - PRINT A COMPLETED ASSESSMENT ; [04/06/00  12:05 PM ]
+ ;;3.0; Surgery ;**38,94**;24 Jun 93
 BATCH ;
  W ! K DIR S DIR("?",1)="Enter YES to batch print all completed or transmitted assessments for a",DIR("?",2)="selected date range.  Enter NO or press return to print one specific",DIR("?")="assessment."
@@ -7,6 +7,6 @@
  S SRPRINT=1 K SRNEW D ^SROASS I '$D(SRTN) S SRSOUT=1 G END
  W ! K %ZIS,IO("Q"),POP S %ZIS("A")="Print the Completed Assessment on which Device: ",%ZIS="Q" D ^%ZIS I POP S SRSOUT=1 G END
- I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN=$S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM") D ^%ZTLOAD G END
- D @($S($P($G(^SRF(SRTN,"RA")),"^",2)="C":"EN^SROACOM1",1:"EN^SROACOM"))
+ I $D(IO("Q")) K IO("Q") S ZTDESC="Completed Surgery Risk Assessment",ZTSAVE("SRSITE*")="",ZTSAVE("SRTN")="",ZTRTN="EN^SROACOM" D ^%ZTLOAD G END
+ D EN^SROACOM
 END D ^%ZISC W @IOF K SRTN D ^SRSKILL
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROATCM3.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROATCM3.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROATCM3.m	(revision 636)
@@ -1,4 +1,4 @@
-SROATCM3 ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;12/03/07
- ;;3.0; Surgery ;**125,135,153,164,166**;24 Jun 93;Build 6
+SROATCM3 ;BIR/SJA - STUFF TRANMISSION IN ^TMP ;08/24/07
+ ;;3.0; Surgery ;**125,135,153,164**;24 Jun 93;Build 2
  N SRDISP,NYUK S SRDISP="",NYUK=$P(SRRES(1),U,2),SRA(209.1)=$G(^SRF(SRTN,209.1)),SRA(207.1)=$G(^SRF(SRTN,207.1))
  I NYUK'="" D
@@ -14,7 +14,6 @@
  S SHEMP=SHEMP_$J($P(SRA(209),"^",11),2)_$J(Y,5)
  S X=$P(SRA(209),"^",12) S:X="" X="N" S SHEMP=SHEMP_$J(X,2)
- ; CT Surgery Consult Date and cause for delay
+ ; CT Surgery Consult Date
  S SRDATE=$P(SRA(209),"^",15),SRDATE=$$LJ^XLFSTR(SRDATE,7,0),SHEMP=SHEMP_SRDATE
- S X=$P(SRA(209),"^",16),SHEMP=SHEMP_$J(X,2)
  S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SRACNT=SRACNT+1
 LN27 ;Line #27 - Other Cardiac Procedures
Index: FOIAVistA/tag/r/SURGERY-SR/SROATM1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROATM1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROATM1.m	(revision 636)
@@ -1,4 +1,4 @@
-SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;12/10/07
- ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160,166**;24 Jun 93;Build 6
+SROATM1 ;BIR/MAM - NON CARDIAC TRANSMISSION ;05/10/07
+ ;;3.0; Surgery ;**27,38,47,60,62,81,88,93,95,125,153,160**;24 Jun 93;Build 7
  ;** NOTICE: This routine is part of an implementation of a nationally
  ;**         controlled procedure. Local modifications to this routine
@@ -7,11 +7,10 @@
  ; Reference to ^DIC(45.3 supported by DBIA #218
  ;
- N SRINTUB,SRDTH,SRPID,SRCDT,SRCREQ F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I))
+ N SRINTUB,SRDTH,SRPID F I=0,200,200.1,206 S SRA(I)=$G(^SRF(SRTN,I))
  S DFN=$P(SRA(0),"^") N I D DEM^VADPT S SRANAME=VADM(1),SEX=$P(VADM(5),"^"),Z=$P(VADM(3),"^"),SRSDATE=$E($P(SRA(0),"^",9),1,12),Y=$E(SRSDATE,1,7),AGE=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
  S SRPID=VA("PID"),SRPID=$TR(SRPID,"-","") ; remove hyphens from PID
  S X=$$SITE^SROUTL0(SRTN),SRDIV=$S(X:$P(^SRO(133,X,0),"^"),1:""),SRDIV=$S(SRDIV:$$GET1^DIQ(4,SRDIV,99),1:SRASITE)
  S X=$P($G(^SRF(SRTN,205)),"^",3),SRDTH=$S(X:X,1:$P(VADM(6),"^"))
- S SRCDT=$P($G(^SRF(SRTN,209)),"^",15),SRCREQ=$P($G(^SRF(SRTN,209)),"^",17)
- S SHEMP=">"_$J(SRASITE,3)_$J(SRTN,7)_"  1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRDTH,12)_$J(SRCDT,7)_$J(SRCREQ,7)
+ S SHEMP=">"_$J(SRASITE,3)_$J(SRTN,7)_"  1"_DT_$J(AGE,3)_$J(SEX,1)_$J(SRSDATE,12)_$J(SRPID,20)_$J(SRDIV,6)_$J(SRDTH,12)
  S ^TMP("SRA",$J,SRAMNUM,SRACNT,0)=SHEMP,SHEMP=$E(SHEMP,1,11)_"  2",SRACNT=SRACNT+1
  S NYUK=$P(SRA(200),"^",2) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",3) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200),"^",4) D ONE S SHEMP=SHEMP_MOE,NYUK=$P(SRA(200.1),"^",2) D ONE S SHEMP=SHEMP_MOE
Index: FOIAVistA/tag/r/SURGERY-SR/SROATMNO.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROATMNO.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROATMNO.m	(revision 636)
@@ -1,4 +1,4 @@
-SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;12/18/07
- ;;3.0; Surgery ;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160,166**;24 Jun 93;Build 6
+SROATMNO ;BIR/MAM - TRANSMIT NO ASSESSMENT ;05/10/07
+ ;;3.0; Surgery ;**27,38,47,62,68,79,83,81,88,93,95,97,129,125,142,153,160**;24 Jun 93;Build 7
  ;** NOTICE: This routine is part of an implementation of a nationally
  ;**         controlled procedure. Local modifications to this routine
@@ -15,5 +15,4 @@
  I $P($G(^SRF(SRTN,30)),"^")!$P($G(^SRF(SRTN,31)),"^",8)!'$P($G(^SRF(SRTN,.2)),"^",12)!($P($G(^SRF(SRTN,"NON")),"^")="Y") K ^SRF("AQ",TDATE,SRTN) S $P(^SRF(SRTN,.4),"^",2)="" Q
  I $P($G(^SRF(SRTN,"RA")),"^",6)="Y",$P($G(^SRF(SRTN,"RA")),"^",2)="N" K ^SRF("AQ",TDATE,SRTN) Q
- I $P($G(^SRF(SRTN,0)),"^",9)="" K ^SRF("AQ",TDATE,SRTN) Q
  S SR10SP="          " K DA,DIE,DR S DA=SRTN,DIE=130,DR="905///R" D ^DIE K DR,DA,DIE
  S SRA(0)=^SRF(SRTN,0),DATE=$E($P(SRA(0),"^",9),1,7),SPEC=$P(SRA(0),"^",4) S:SPEC SPEC=$P(^DIC(45.3,$P(^SRO(137.45,SPEC,0),"^",2),0),"^")
@@ -39,5 +38,5 @@
  D OCC
  S SRNODE="  X" S:$P($G(^SRF(SRTN,"RA")),U,6)="N" SRNODE="  *" S:$P($G(^SRF(SRTN,"RA")),U,2)="C" SRNODE="  C"
- S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_$J(DATE,7)_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_" "
+ S SRTEMP="/"_$J(SRASITE,3)_$J(SRTN,7)_SRNODE_DATE_$J(SRTECH,3)_$J(EMERG,1)_$J(SPEC,3)_$J(CPT,5)_$J(EXC,1)_$J(SRPID,20)_$J(SRDIV,6)_" "
  S SRTEMP=SRTEMP_$J(SRMAJMIN,1)_$J($E(SRDEATH,1,7),7)_$J(SRDTHUR,1)_$J(SRSTATUS,1)_$J(SRAGE,3)_$J(SRASA,2)_$J(SRADMIT,1)_SRTMP
  K CPT,SRMOD F SRZ=1:1:10 S (CPT(SRZ),SRMOD(SRZ))=""
Index: FOIAVistA/tag/r/SURGERY-SR/SROAUTL.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAUTL.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAUTL.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;03/03/08
- ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160,166**;24 Jun 93;Build 6
+SROAUTL ;BIR/ADM - RISK ASSESSMENT UTILITY ;02/14/07
+ ;;3.0; Surgery ;**38,46,47,63,81,88,95,112,100,125,134,142,153,160**;24 Jun 93;Build 7
  I $G(SRSUPCPT)=2 G NCODE
  N SRCMOD,SRCOMMA,X K SRHDR S DFN=$P(^SRF(SRTN,0),"^") D DEM^VADPT S SRHDR=VADM(1)_" ("_VA("PID")_")      Case #"_SRTN
@@ -42,5 +42,5 @@
  I $$CARD,X="NA"!(X="NS") K X
  Q
-DATE ; called by output transform on several date fields
+DATE ; called by output transmform on several date fields
  I $D(Y),Y="NA"!(Y="NS") Q
  N SRY S SRY=Y D DD^%DT
@@ -96,7 +96,7 @@
 OCCEND K ^TMP("SROCC",$J)
  Q
-PREOP S DR="236;237;346;202;246;325;238;492;204;203;326;212;213;396;394;220;266;395;208;329;330;328;211;332;333;400;334;335;336;401;338;218;339;215;216;217;338.1;338.2;218.1;269"
+PREOP S DR="236;237;346;202;202.1;246;325;238;240;492;204;203;326;212;213;396;394;220;266;395;208;329;330;328;211;332;333;398;399;400;334;335;336;401;338;218;339;215;216;217;338.1;338.2;218.1;269"
  Q
-DEM S DR="413;.011;247;418;419;420;421;452;453;454;342;513;516"
+DEM S DR="413;.011;247;418;419;420;421;452;453;454;342"
  Q
 LAB S DR="270;304;224;291;223;290;225;292;228;295;227;294;229;296;230;297;234;301;231;298;233;300;232;299;487;487.1;274;305;405;407;275;306;406;408;277;308;278;309;279;310;280;311;281;312;283;314;455;455.1;456;456.1;444;444.1;445;445.1"
Index: FOIAVistA/tag/r/SURGERY-SR/SROAUTL1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAUTL1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAUTL1.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAUTL1 ;BIR/ADM - RISK ASSESSMENT UTILITY ;12/10/07
- ;;3.0; Surgery ;**38,47,81,125,153,160,166**;24 Jun 93;Build 6
+SROAUTL1 ;BIR/ADM - RISK ASSESSMENT UTILITY ;04/24/07
+ ;;3.0; Surgery ;**38,47,81,125,153,160**;24 Jun 93;Build 7
  S SRZ=0 F  S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ  I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRX(SRZ)=$P(SRFLD,"^",2)
  Q
@@ -15,11 +15,15 @@
 CID ;;394^History of MI Within Past 6 Months (Y/N)^MI Within 6 Months^
 CIE ;;395^Angina within One Month Preceding Surgery (Y/N)^Angina Within 1 Month^
+CIH ;;398^Quadriplegia/Tetraplegia/Quadriparesis (Y/N)^Quadriplegia^
+CII ;;399^Paraplegia (Y/N)^Paraplegia^
 BCF ;;236^Patient's Height^Height^
 BCG ;;237^Patient's Weight^Weight^
 CDF ;;346^Diabetes^Diabetes Mellitus^
 BJB ;;202^Current Smoker within 1 Year prior to Surgery (Y/N)^Current SmokerW/I 1 Year^
+BJBPA ;;202.1^Pack/Years^Pack/Years^
 BDF ;;246^ETOH Greater than 2 Drinks/Day (Y/N)^ETOH > 2 Drinks/Day^
 CBE ;;325^Dyspnea^Dyspnea^
 BCH ;;238^DNR Status (Y/N)^DNR Status^
+BDJ ;;240^Functional Health Status Prior to Current Illness^Pre-Illness Functional Status^
 DIB ;;492^Functional Health Status at Evaluation for Surgery^Preop Functional Status
 BJD ;;204^Ventilator Dependent Greater than 48 Hrs (Y/N)^Ventilator Dependent^
@@ -59,4 +63,2 @@
 DEC ;;453^Observation Discharge Date/Time
 DED ;;454^Observation Treating Specialty
-EAC ;;513^Surgery Consult Date
-EAF ;;516^Date Surgery Consult Requested
Index: FOIAVistA/tag/r/SURGERY-SR/SROAUTL3.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAUTL3.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAUTL3.m	(revision 636)
@@ -1,4 +1,4 @@
-SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/07/08
- ;;3.0; Surgery ;**38,47,63,77,142,163,166**;24 Jun 93;Build 6
+SROAUTL3 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/16/07
+ ;;3.0; Surgery ;**38,47,63,77,142,163**;24 Jun 93;Build 2
  ;
  ; Reference to ^DIC(45.3 supported by DBIA #218
@@ -15,5 +15,4 @@
  Q
 CARD ; allow input of cardiac risk assessment preop information
- N SRSDATE,SRNM,SRSOUT
  W @IOF,!,"Enter Cardiac Preoperative information",!!,"  1. Clinical Information",!,"  2. Cardiac Catheterization & Angiographic Data",!,"  3. Operative Risk Summary Data",!
  K DIR S DIR(0)="NO^1:3:0",DIR("?")="Enter the number of the selection to be edited." D ^DIR K DIR I $D(DTOUT)!$D(DUOUT)!'Y Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROAUTL4.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAUTL4.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAUTL4.m	(revision 636)
@@ -1,16 +1,11 @@
-SROAUTL4 ;BIR/ADM - RISK ASSESSMENT UTILITY ;01/10/08
- ;;3.0; Surgery ;**38,71,95,125,153,160,164,166**;24 Jun 93;Build 6
- N SRZZ,SRXX,SRX1
+SROAUTL4 ;BIR/ADM - RISK ASSESSMENT UTILITY ;08/24/07
+ ;;3.0; Surgery ;**38,71,95,125,153,160,164**;24 Jun 93;Build 2
  S SRZ=0 F  S SRZ=$O(SRY(130,SRTN,SRZ)) Q:'SRZ  D
- .I SRY(130,SRTN,SRZ,"I")="" D TR S (SRX1,X)=$T(@SRP),SRFLD=$P(X,";;",2) D
+ .I SRY(130,SRTN,SRZ,"I")="" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2) D
+ ..I SRZ=451!(SRZ=450) S SRX($P(SRFLD,"^",2))=$P(SRFLD,"^",2)_"^"_SRZ Q
  ..I SRZ=513,$P(^SRF(SRTN,0),"^",9)<3071001 Q
- ..I SRZ=515  S X1=$P(^SRF(SRTN,0),"^",9),X2=$P($G(^SRF(SRTN,209)),"^",15) D ^%DTC I X'>30 Q
- ..I SRZ=484,$P($G(^SRF(SRTN,209)),"^",13)'="Y" Q
- ..S X=SRX1,SRX(SRZ)=$P(SRFLD,"^",2)_"^"_$P(X,";;",3)
+ ..S SRX(SRZ)=$P(SRFLD,"^",2)
  .I SRY(130,SRTN,SRZ,"I")="NS" D TR S X=$T(@SRP),SRFLD=$P(X,";;",2),SRDT=$P(SRFLD,"^",4) S:SRDT'="" SRLR(SRDT)=""
  S SRDT=0 F  S SRDT=$O(SRLR(SRDT)) Q:'SRDT  K SRX(SRDT)
- Q
-RED M SRZZ=SRX S SRZ=0 F  S SRZ=$O(SRX(SRZ)) Q:'SRZ  S SRZZ=$P($G(SRX(SRZ)),"^",2),SRXX(SRZZ)=$P($G(SRX(SRZ)),"^")_":"_SRZ
- K SRX M SRX=SRXX K SRXX
  Q
 TR S SRP=SRZ,SRP=$TR(SRP,"1234567890.","ABCDEFGHIJP")
@@ -18,110 +13,110 @@
 GET S X=$T(@J)
  Q
-BCF ;;236^Patient's Height^Height^;;1-01
-BCG ;;237^Patient's Weight^Weight^;;1-02
-DGE ;;475^Diabetes (Cardiac);;1-03
-BJC ;;203^History of COPD (Y/N)^COPD^;;1-04
-CDG ;;347^FEV1^FEV1^;;1-05
-BJI ;;209^Cardiomegaly on Chest X-Ray (Y/N)^Cardiomegaly (X-ray)^;;1-06
-CDH ;;348^Pulmonary Rales (Y/N)^Pulmonary Rales^;;1-07
-EAJ ;;510^Current Smoker^Current Smoker^;;1-08
-CDI ;;349^Active Endocarditis (Y/N)^Active Endocarditis^;;1-09
-CEJ ;;350^Resting ST Depression (Y/N)^Resting ST Depression^;;1-10
-BDJ ;;240^Functional Health Status^Functional Status^;;1-11
-CEA ;;351^PCI Status^PCI^;;1-12
-BJE ;;205^Prior Myocardial Infarction^Prior MI^;;1-13
-CEB ;;352^Number of Prior Heart Surgeries^Number of Prior Heart Surgeries^;;1-14
-DHE ;;485^Prior Heart Surgeries;;1-15
-BFE ;;265^Peripheral Vascular Disease (Y/N)^Peripheral Vascular Disease^;;1-16
-BFD ;;264^Cerebral Vascular Disease (Y/N)^Cerebral Vascular Disease^;;1-17
-BFG ;;267^Angina (use NYHA Functional Class)^Angina (use CCS Class)^;;1-18
-BJG ;;207^Congestive Heart Failure (use NYHA Functional Class)^CHF (use NYHA Class)^;;1-19
-CEC ;;353^Current Diuretic Use (Y/N)^Current Diuretic Use^;;1-20
-CED ;;354^Current Digoxin Use (Y/N)^Current Digoxin Use^;;1-21
-CEE ;;355^IV NTG within 48 Hours Preceding Surgery (Y/N)^IV NTG within 48 Hours^;;1-22
-DGD ;;474^Preop use of circulatory Device;;1-23
-DFC ;;463^Hypertension^;;1-24
-DEG ;;457^HDL^^457.1;;2-01
-DEGPA ;;457.1^HDL, Date;;2-02
-DFA ;;461^LDL^^461.1;;2-03
-DFAPA ;;461.1^LDL, Date;;2-04
-DFB ;;462^Total Cholesterol^^462.1;;2-05
-DFBPA ;;462.1^Total Cholesterol, Date;;2-06
-DEH ;;458^Serum Triglyceride^^458.1;;2-07
-DEHPA ;;458.1^Serum Triglyceride, Date;;2-08
-DEI ;;459^Serum Potassium^^459.1;;2-09
-DEIPA ;;459.1^Serum Potassium, Date;;2-10
-DFJ ;;460^Serum Total Bilirubin^^460.1;;2-11
-DFJPA ;;460.1^Serum Total Bilirubin, Date;;2-12
-BBC ;;223^Preoperative Serum Creatinine^Creatinine^290;;2-13
-BIJ ;;290^Creatinine Date;;2-14
-BBE ;;225^Preoperative Serum Albumin^^292;;2-15
-BIB ;;292^Preoperative Serum Albumin Date;;2-16
-BAI ;;219^Preoperative Hemoglobin^^239;;2-17
-BCI ;;239^Preoperative Hemoglobin Date;;2-18
-EJD ;;504^Hemoglobin A1c^^504.1;;2-19
-EJDPA ;;504.1^Hemoglobin A1c, Date;;2-20
-DGF ;;476^Procedure Type;;3-01
-CEG ;;357^Left Ventricular End-Diastolic Pressure^LVEDP^;;3-02
-CEH ;;358^Aortic Systolic Pressure^Aortic Systolic Pressure^;;3-03
-CEI ;;359^PA Systolic Pressure^*PA Systolic Pressure^;;3-04
-CFJ ;;360^PAW Mean Pressure^*PAW Mean Pressure^;;3-05
-CFC ;;363^LV Contraction Grade^LV Contraction Grade  (from contrast or radionuclide angiogram or 2D echo^;;3-06
-DAE ;;415^Mitral Regurgitation^Mitral Regurgitation^;;3-07
-DGG ;;477^Aortic Stenosis;;3-08
-CFA ;;361^Left Main Stenosis^Left Main Stenosis^;;3-09
-CFBPA ;;362.1^Left Anterior Descending (LAD) Stenosis^LAD Stenosis^;;3-10
-CFBPB ;;362.2^Right Coronary Artery Stenosis^Right Coronary Stenosis^;;3-11
-CFBPC ;;362.3^Circumflex Coronary Artery Stenosis^Circumflex Stenosis^;;3-12
-DGH ;;478^Re-Do Lad Stenosis;;3-13
-DGI ;;479^Re-Do Right Coronary Stenosis;;3-14
-DHJ ;;480^Re-Do Circumflex Stenosis;;3-15
-CFD ;;364^Physician's Preoperative Estimate of Operative Mortality^Physician's Preoperative Estimate of Operative Mortality^;;4-01
-CFDPA ;;364.1^Date/Time of Estimate of Operative Mortality^Date/Time of Estimate of Operative Mortality^;;4-02
-APAC ;;1.13^ASA Class^ASA Classification^;;4-03
-DAD ;;414^Cardiac Surgical Priority^Surgical Priority^;;4-04
-DADPA ;;414.1^Date/Time of Cardiac Surgical Priority^Date/Time of Cardiac Surgical Priority^;;4-05
-PBB ;;.22^Time the Operation Began^Date/Time Operation Began^;;4-06
-PBC ;;.23^Time the Operation Ended^Date/Time Operation Ended^;;4-07
-CFE ;;365^CABG Distal Anastomoses with Vein^^;;5-01
-CFF ;;366^CABG Distal Anastomoses with IMA^^;;5-02
-DFD ;;464^Number with Radial Artery^;;5-03
-DFE ;;465^Number with Other Artery^;;5-04
-DAF ;;416^CABG Distal Anastomoses with Other Conduit^^;;5-05
-CFG ;;367^Aortic Valve Replacement (Y/N)^Aortic Valve Replacement^;;5-06
-CFH ;;368^Mitral Valve Replacement (Y/N)^Mitral Valve Replacement^;;5-07
-CFI ;;369^Tricuspid Valve Replacement (Y/N)^Tricuspid Valve Replacement^;;5-08
-CGJ ;;370^Valve Repair (Y/N)^Valve Repair^;;5-09
-CGA ;;371^LV Aneurysmectomy (Y/N)^LV Aneurysmectomy^;;5-10
-DHA ;;481^Bridge to transplant/Device;;5-11
-DHC ;;483^Transmyocardial Laser Revascularization;;5-12
-EAB ;;512^Maze Procedure;;5-13
-CGF ;;376^ASD Repair (Y/N)^ASD Repair^;;5-14
-CHJ ;;380^VSD Repair (Y/N)^VSD Repair^;;5-15
-CGH ;;378^Myectomy for IHSS (Y/N)^Myectomy for IHSS^;;5-16
-CGG ;;377^Myxoma Resection (Y/N)^Myxoma Resection^;;5-17
-CGI ;;379^Other Tumor Resection (Y/N)^Other Tumor Resection^;;5-18
-CGC ;;373^Cardiac Transplant (Y/N)^Cardiac Transplant^;;5-19
-CGB ;;372^Great Vessel Repair(Y/N)^Great Vessel Repair^;;5-20
-EJE ;;505^Endovascular Repair of Descending Thoracic Aorta (Y/N)^Endovascular Repair;;5-21
-EJB ;;502^Other Cardiac Procedures (Y/N);;5-22
-DHD ;;484^Other cardiac procedures (specify);;5-23
-CHA ;;381^Foreign Body Removal (Y/N)^Foreign Body Removal^;;5-24
-CHB ;;382^Pericardiectomy (Y/N)^Pericardiectomy^;;5-25
-DEA ;;451^Total CPB Time;;5-26
-DEJ ;;450^Total Ischemic Time;;5-27
-DFH ;;468^Incision Type^;;5-28
-DFI ;;469^Covert From Off Pump to CPB;;5-29
-CHD ;;384^Operative Death (Y/N)^Operative Death^;;6-01
-DAH ;;418^Hospital Admission Date And Time;;7-01
-DAI ;;419^Hospital Discharge Date And Time;;7-02
-DDJ ;;440^Cardiac Catheterization Date;;7-03
-PBJE ;;.205^Time Patient In OR;;7-04
-PBCB ;;.232^Time Patient Out OR;;7-05
-DGJ ;;470^Date and Time Patient Extubated;;7-06
-DGA ;;471^Date and Time Patient Discharged from ICU;;7-07
-DGC ;;473^Homeless(Y/N);;7-08
-DGB ;;472^Cardiac Surgery to NON-VA Facility;;7-09
-DDB ;;442^Employment Status;;7-10
-EAC ;;513^CT Surgery Consult Date;;7-11
-EAE ;;515^Cause for Delay for Cardiac Surgery;;7-12
+PBB ;;.22^Time the Operation Began^Date/Time Operation Began^
+PBC ;;.23^Time the Operation Ended^Date/Time Operation Ended^
+BCF ;;236^Patient's Height^Height^
+BCG ;;237^Patient's Weight^Weight^
+CDF ;;346^Diabetes^Diabetes^
+BJC ;;203^History of COPD (Y/N)^COPD^
+CDG ;;347^FEV1^FEV1^
+BJI ;;209^Cardiomegaly on Chest X-Ray (Y/N)^Cardiomegaly (X-ray)^
+CDH ;;348^Pulmonary Rales (Y/N)^Pulmonary Rales^
+EAJ ;;510^Current Smoker^Current Smoker^
+BBC ;;223^Preoperative Serum Creatinine^Creatinine^290
+CDI ;;349^Active Endocarditis (Y/N)^Active Endocarditis^
+CEJ ;;350^Resting ST Depression (Y/N)^Resting ST Depression^
+BDJ ;;240^Functional Health Status^Functional Status^
+CEA ;;351^PCI Status^PCI^
+BJE ;;205^Prior Myocardial Infarction^Prior MI^
+CEB ;;352^Number of Prior Heart Surgeries^Number of Prior Heart Surgeries^
+BFE ;;265^Peripheral Vascular Disease (Y/N)^Peripheral Vascular Disease^
+BFD ;;264^Cerebral Vascular Disease (Y/N)^Cerebral Vascular Disease^
+BFG ;;267^Angina (use NYHA Functional Class)^Angina (use CCS Class)^
+BJG ;;207^Congestive Heart Failure (use NYHA Functional Class)^CHF (use NYHA Class)^
+CEC ;;353^Current Diuretic Use (Y/N)^Current Diuretic Use^
+CED ;;354^Current Digoxin Use (Y/N)^Current Digoxin Use^
+CEE ;;355^IV NTG within 48 Hours Preceding Surgery (Y/N)^IV NTG within 48 Hours^
+CEF ;;356^Preoperative use of IABP (Y/N)^Preop Use of IABP^
+CEG ;;357^Left Ventricular End-Diastolic Pressure^LVEDP^
+CEH ;;358^Aortic Systolic Pressure^Aortic Systolic Pressure^
+CEI ;;359^PA Systolic Pressure^*PA Systolic Pressure^
+CFJ ;;360^PAW Mean Pressure^*PAW Mean Pressure^
+CFA ;;361^Left Main Stenosis^Left Main Stenosis^
+CFBPA ;;362.1^Left Anterior Descending (LAD) Stenosis^LAD Stenosis^
+CFBPB ;;362.2^Right Coronary Artery Stenosis^Right Coronary Stenosis^
+CFBPC ;;362.3^Circumflex Coronary Artery Stenosis^Circumflex Stenosis^
+CFC ;;363^LV Contraction Grade^LV Contraction Grade  (from contrast or radionuclide angiogram or 2D echo^
+DAE ;;415^Mitral Regurgitation^Mitral Regurgitation^
+CFD ;;364^Physician's Preoperative Estimate of Operative Mortality^Physician's Preoperative Estimate of Operative Mortality^
+CFDPA ;;364.1^Date/Time of Estimate of Operative Mortality^Date/Time of Estimate of Operative Mortality^
+APAC ;;1.13^ASA Class^ASA Classification^
+DAD ;;414^Cardiac Surgical Priority^Surgical Priority^
+DADPA ;;414.1^Date/Time of Cardiac Surgical Priority^Date/Time of Cardiac Surgical Priority^
+CHD ;;384^Operative Death (Y/N)^Operative Death^
+CFE ;;365^CABG Distal Anastomoses with Vein^^
+CFF ;;366^CABG Distal Anastomoses with IMA^^
+CFG ;;367^Aortic Valve Replacement (Y/N)^Aortic Valve Replacement^
+CFH ;;368^Mitral Valve Replacement (Y/N)^Mitral Valve Replacement^
+CFI ;;369^Tricuspid Valve Replacement (Y/N)^Tricuspid Valve Replacement^
+CGJ ;;370^Valve Repair (Y/N)^Valve Repair^
+CGA ;;371^LV Aneurysmectomy (Y/N)^LV Aneurysmectomy^
+CGB ;;372^Great Vessel Repair(Y/N)^Great Vessel Repair^
+EJE ;;505^Endovascular Repair of Descending Thoracic Aorta (Y/N)^Endovascular Repair
+CGC ;;373^Cardiac Transplant (Y/N)^Cardiac Transplant^
+CGF ;;376^ASD Repair (Y/N)^ASD Repair^
+CHJ ;;380^VSD Repair (Y/N)^VSD Repair^
+CGG ;;377^Myxoma Resection (Y/N)^Myxoma Resection^
+CHA ;;381^Foreign Body Removal (Y/N)^Foreign Body Removal^
+CGH ;;378^Myectomy for IHSS (Y/N)^Myectomy for IHSS^
+CHB ;;382^Pericardiectomy (Y/N)^Pericardiectomy^
+CGI ;;379^Other Tumor Resection (Y/N)^Other Tumor Resection^
+DAF ;;416^CABG Distal Anastomoses with Other Conduit^^
+DDB ;;442^Employment Status
+BAI ;;219^Preoperative Hemoglobin^^239
+BCI ;;239^Preoperative Hemoglobin Date
+BBE ;;225^Preoperative Serum Albumin^^292
+BIB ;;292^Preoperative Serum Albumin Date
+BIJ ;;290^Creatinine Date
+DEA ;;451^Total CPB Time
+DEJ ;;450^Total Ischemic Time
+DDJ ;;440^Cardiac Catheterization Date
+DAH ;;418^Hospital Admission Date And Time
+DAI ;;419^Hospital Discharge Date And Time
+DFC ;;463^Hypertension^
+DFD ;;464^Number with Radial Artery^
+DFE ;;465^Number with Other Artery^
+DFH ;;468^Incision Type^
+DFI ;;469^Covert From Off Pump to CPB
+DGJ ;;470^Date and Time Patient Extubated
+DGA ;;471^Date and Time Patient Discharged from ICU
+DGB ;;472^Cardiac Surgery to NON-VA Facility
+PBJE ;;.205^Time Patient In OR
+PBCB ;;.232^Time Patient Out OR
+DEG ;;457^HDL^^457.1
+DEGPA ;;457.1^HDL, Date
+DEH ;;458^Serum Triglyceride^^458.1
+DEHPA ;;458.1^Serum Triglyceride, Date
+DEI ;;459^Serum Potassium^^459.1
+DEIPA ;;459.1^Serum Potassium, Date
+DFJ ;;460^Serum Total Bilirubin^^460.1
+DFJPA ;;460.1^Serum Total Bilirubin, Date
+DFA ;;461^LDL^^461.1
+DFAPA ;;461.1^LDL, Date
+DFB ;;462^Total Cholesterol^^462.1
+DFBPA ;;462.1^Total Cholesterol, Date
+EJD ;;504^Hemoglobin A1c^^504.1
+EJDPA ;;504.1^Hemoglobin A1c, Date
+DGE ;;475^Diabetes (Cardiac)
+DGD ;;474^Preop use of circulatory Device
+DGF ;;476^Procedure Type
+DGG ;;477^Aortic Stenosis
+DGH ;;478^Re-Do Lad Stenosis
+DGI ;;479^Re-Do Right Coronary Stenosis
+DHJ ;;480^Re-Do Circumflex Stenosis
+DHA ;;481^Bridge to transplant/Device
+EAB ;;512^Maze Procedure
+DHC ;;483^Transmyocardial Laser Revascularization
+EJB ;;502^Other Cardiac Procedures (Y/N)
+DHD ;;484^Other cardiac procedures (specify)
+DHE ;;485^Prior Heart Surgeries
+EAC ;;513^CT Surgery Consult Date
Index: FOIAVistA/tag/r/SURGERY-SR/SROAUTLC.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROAUTLC.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROAUTLC.m	(revision 636)
@@ -1,4 +1,4 @@
 SROAUTLC ;BIR/ADM - CARDIAC RISK ASSESSMENT UTILITY ;08/23/07
- ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164,166**;24 Jun 93;Build 6
+ ;;3.0; Surgery ;**38,71,90,88,95,97,102,96,125,153,163,164**;24 Jun 93;Build 2
  ;
  ; Reference to ^DIC(45.3 supported by DBIA #218
@@ -43,20 +43,13 @@
  Q
 CHK ; check for missing cardiac assessment information
- K SRX,SRZZ F SRC="CLIN","LAB","CATH","OP","CAR","OUT","R" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL4
- D RED^SROAUTL4
+ K SRX F SRC="CLIN","COC","CP","CLR" K DA,DIC,DIQ,DR,SRY S DIC="^SRF(",DA=SRTN,DIQ="SRY",DIQ(0)="I" D @SRC D EN^DIQ1 D ^SROAUTL4
  Q
-CLIN S DR="236;237;475;203;347;209;348;510;349;350;240;351;205;352;485;265;264;267;207;353;354;355;474;463"
+CLIN S DR="236;237;475;203;347;209;348;510;223;290;219;239;225;292;349;350;240;351;205;352;485;265;264;267;207;353;354;355;463;474"
  Q
-CATH S DR="476;357;358;359;360;363;415;477;361;362.1;362.2;362.3;478;479;480"
+COC S DR="476;477;357;358;359;360;361;362.1;362.2;362.3;363;415;474;364;364.1;1.13;414;414.1;384;.22;.23;472;478;479;480"
  Q
-R S DR="418;419;440;.205;.232;470;471;473;472;442;513;515"
- Q
-OP S DR="364;364.1;1.13;414;414.1;.22;.23"
- Q
-OUT S DR="384"
- Q
-CAR S DR="365;366;464;465;416;367;368;369;370;371;481;483;512;376;380;378;377;379;373;372;505;502;381;382;451;450;468;469"
+CP S DR="365;366;464;465;416;367;368;369;370;371;372;505;450;451;373;376;380;377;381;378;382;379;468;469;.205;.232;470;471;418;419;440;481;512;483;502;513"
  I $P($G(^SRF(SRTN,209)),"^",13)="Y"!($P($G(^SRF(SRTN,209)),"^",13)="") S DR=DR_";484"
  Q
-LAB S DR="457;457.1;461;461.1;462;462.1;458;458.1;459;459.1;460;460.1;223;290;225;292;219;239;504;504.1"
+CLR S DR="457;457.1;458;458.1;459;459.1;460;460.1;461;461.1;462;462.1;504;504.1"
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROCODE.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROCODE.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROCODE.m	(revision 636)
@@ -1,9 +1,9 @@
-SROCODE ;BIR/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ;01/30/08
- ;;3.0; Surgery ;**72,41,114,151,166**;24 Jun 93;Build 6
+SROCODE ;B'HAM ISC/MAM - SET UP FLAG FOR ANESTHESIA AGENTS ; [ 05/06/98   7:14 AM ]
+ ;;3.0; Surgery ;**72,41,114,151**;24 Jun 93
  ;
  ; Reference to ENS^PSSGIU supported by DBIA #895
+ ; Reference to ^PSS50 supported by DBIA #4533
  ;
-1 N SRTEST S SRTEST=50,SRTEST(0)="AEQSZ",SRTEST("A")="Enter the name of the drug you wish to flag: "
- D DIC^PSSDI(50,"SR",.SRTEST) G:+Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU
+1 W !! K DIR S DIR(0)="P^50:QEAM",DIR("A")="Enter the name of the drug you wish to flag" D ^DIR G:Y<1 DONE S SROIUDA=+Y,SROIRX=$P(Y,"^",2),SROIUX="S^SURGERY" D SROIU
  G 1
 SROIU Q:'$D(SROIUDA)!'$D(SROIUX)  Q:SROIUX'?1E1"^"1.E
Index: FOIAVistA/tag/r/SURGERY-SR/SROESPR1.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROESPR1.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROESPR1.m	(revision 636)
@@ -1,4 +1,4 @@
 SROESPR1 ;BIR/ADM - SURGERY E-SIG UTILITY ; [ 04/21/04  12:08 PM ]
- ;;3.0; Surgery ;**100,128,162**;24 Jun 93;Build 4
+ ;;3.0; Surgery ;**100,128**;24 Jun 93
  ;
  ;** NOTICE: This routine is part of an implementation of a nationally
@@ -98,5 +98,4 @@
  . S SRY=4 D SETCONT() Q:'SRCONT
  . W !!,$$DATE^SROESPR(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,1301,"I"),"MM/DD/CCYY HR:MIN"),?21,"ADDENDUM"
- . W ?41,"STATUS: ",^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,.05,"E")
  . S SRI=0
  . F  S SRI=$O(^TMP("SRLQ",$J,SRDA,"ZADD",SRADD,"TEXT",SRI)) Q:SRI'>0  D  Q:'SRCONT
Index: FOIAVistA/tag/r/SURGERY-SR/SROGMTS.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROGMTS.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROGMTS.m	(revision 636)
@@ -1,4 +1,4 @@
 SROGMTS ;BIR/ADM - SURGERY HEALTH SUMMARY ; [ 08/08/01  7:12 AM ]
- ;;3.0; Surgery ;**100,127,162**;24 Jun 93;Build 4
+ ;;3.0; Surgery ;**100,127**;24 Jun 93
  ;
  ;** NOTICE: This routine is part of an implementation of a nationally
@@ -22,6 +22,14 @@
  S:'SRSG DR=".09;.31;26;27;33;50;55;59;66;121;122;123;124;125"
  D EN^DIQ1 S REC(130,IEN,"STATUS")=$$OS(IEN) S:+SRSG REC(130,IEN,"VERIFIED")=$S($G(REC(130,IEN,43,"I"))'="Y":"(Unverified)",1:"")
- S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),130,27)
- D DICT^SROGMTS0,SUB,SPD
+ S SRM=$G(REC(130,IEN,27,"I")) I SRM>0 D
+ . S SRC=$$CPT^ICPTCOD(SRM,$P($G(^SRF(IEN,0)),"^",9)),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
+ . S REC(130,IEN,27,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
+ . S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))
+ . S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS
+ . S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
+ . S REC(130,IEN,27,"N")=SRS
+ . S (REC(130,IEN,26,"S"),REC(130,IEN,27,"S"))=SRT
+ . S REC(130,IEN,27,"S")=SRCS
+ D DICT^SROGMTS0,SUB
  S:$D(REC(130,IEN,32)) REC(130,IEN,32,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,32,"E")))
  S:$D(REC(130,IEN,33)) REC(130,IEN,33,"S")=$$EN2^SROGMTS0($G(REC(130,IEN,33,"E")))
@@ -104,5 +112,14 @@
  . . S DA(SUB)=SRI
  . . D EN^DIQ1
- . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I"))) I SRM>0 D MOD(SRM,FILE,SUB)
+ . . S SRM=+($G(REC(130,+($G(IEN)),SUB,+($G(SRI)),.01,"I")))
+ . . I SRM>0 N SRMOD D
+ . . . S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
+ . . . S SRC=$P(SRMOD,"^",2)
+ . . . S SRS=$P(SRMOD,"^",3)
+ . . . S REC(130,IEN,SUB,SRI,.01,"MID")=SRC
+ . . . S REC(130,IEN,SUB,SRI,.01,"MOD")=SRS
+ . . . S SRT=$$EN2^SROGMTS0(SRS)
+ . . . S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
+ . . . S REC(130,IEN,SUB,SRI,.01,"S")=SRT
  ;
  ; ^SRF(DO,13,I)                .42  Other Proc          13;0  130.16
@@ -147,42 +164,2 @@
 SG(X) ; Surgical (Operative) Record
  S X=$$GET1^DIQ(130,+($G(X)),118,"I") S X=$S(X["Y":0,1:1) Q X
-CPT(SRM,SRDOO,SRFIL,SRFLD) ;Set CPT code into REC array
- S SRC=$$CPT^ICPTCOD(SRM,SRDOO),(SRCS,SRS)=$$EN2^SROGMTS0($P(SRC,"^",3))
- S REC(SRFIL,IEN,SRFLD,"X")=$P(SRC,"^",2)_"^"_$P(SRC,"^",3)
- S SRC=$P(SRC,"^",2),SRT=$$EN2^SROGMTS0($G(REC(130,IEN,26,"E")))
- S:$L(SRS)&(SRS'=SRT) SRT=SRT_" - "_SRS
- S:$L(SRC)=5 SRT=SRT_" (CPT "_SRC_")",SRCS=SRCS_" (CPT "_SRC_")"
- S REC(SRFIL,IEN,SRFLD,"N")=SRS
- S:SRFIL=130 REC(130,IEN,26,"S")=SRT
- S REC(SRFIL,IEN,SRFLD,"S")=SRT
- S REC(SRFIL,IEN,SRFLD,"S")=SRCS
- Q
-MOD(SRM,SRFIL,SUB) ;Set CPT Modifier into REC array
- S SRMOD=$$MOD^ICPTMOD(+SRM,"I",$P($G(^SRF(IEN,0)),"^",9))
- S SRC=$P(SRMOD,"^",2)
- S SRS=$P(SRMOD,"^",3)
- S REC(SRFIL,IEN,SUB,SRI,.01,"MID")=SRC
- S REC(SRFIL,IEN,SUB,SRI,.01,"MOD")=SRS
- S SRT=$$EN2^SROGMTS0(SRS)
- S:$L(SRC) SRT=SRT_" (CPT Mod "_SRC_")"
- S REC(SRFIL,IEN,SUB,SRI,.01,"S")=SRT
- Q
-SPD ;Obtain Surgery Procedure/Diagnosis Code File entry
- S (FILE,DIC)=136,DA=+($G(IEN)),DIQ="REC(",DIQ(0)="IE"
- S DR=".01;.02;.03;10"
- D EN^DIQ1
- Q:'+$G(REC(FILE,IEN,10,"I"))
- S SRM=+$G(REC(FILE,IEN,.02,"I"))
- Q:'(SRM>0)  D CPT(SRM,$P($G(^SRF(IEN,0)),"^",9),FILE,.02)
- S SUB=136.01,DR=1,DR(SUB)=".01",DIQ="REC(136,"_IEN_","
- K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI))  Q:+SRI=0  D
- .S DA(SUB)=SRI
- .D EN^DIQ1
- .S SRM=REC(FILE,IEN,SUB,SRI,.01,"I") I SRM>0 D MOD(SRM,FILE,SUB)
- N DA S DA=IEN,SUB=136.011,DR=11,DR(SUB)=".01;1"
- K REC(FILE,IEN,SUB) S SRI=0 F  S SRI=$O(^SRO(FILE,(+$G(IEN)),DR,SRI)) Q:+SRI=0  D
- . S DA(SUB)=SRI
- . D EN^DIQ1
- S $P(REC(130,IEN,26,"S"),"-",2)=" "_REC(FILE,IEN,.02,"S")
- K REC(130,IEN,130.028) M REC(130,IEN,130.028)=REC(FILE,IEN,136.01)
- Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROMED.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROMED.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROMED.m	(revision 636)
@@ -1,4 +1,6 @@
-SROMED ;BIR/MAM - ENTER/EDIT MEDICATIONS ;01/30/08
- ;;3.0; Surgery ;**21,44,79,100,151,166**;24 Jun 93;Build 6
+SROMED ;B'HAM ISC/MAM - ENTER/EDIT MEDICATIONS ; [ 01/30/01  12:22 AM ]
+ ;;3.0; Surgery ;**21,44,79,100,151**;24 Jun 93
+ ;
+ ; Reference to ^PSDRUG supported by DBIA #221
  ;
  I '$D(^XUSEC("SROEDIT",DUZ))&'$D(^XUSEC("SROANES",DUZ)) W !!!,$C(7),"You must hold the SROEDIT key or the SROANES key to use this option !",! Q
@@ -10,5 +12,6 @@
  I M?.E1C.E W !!,"Your answer has a control character in it, please re-type it.",! D RET G:SRQ END G START
  S (X,SRMM)=SRM D
- .N SRDIC,SRD S SRDIC=50,SRDIC(0)="EMQSZ",SRD="B^C" D MIX^PSSDI(50,"SR",.SRDIC,SRD,X,,DT)
+ .I $L($T(SCREEN^PSSDI)) N SRTEST S SRTEST=50,SRTEST(0)="EQSZ" D DIC^PSSDI(50,"SR",.SRTEST,X,,DT) Q  ;call PSSDI if PSS*1*104 is released
+ .S DIC="^PSDRUG(",DIC(0)="QEZM",DIC("S")="I $S('$G(^PSDRUG(Y,""I"")):1,DT'>^(""I""):1,1:0)" D ^DIC K DIC
  S SRM=$S(Y<0:"",1:$P(Y,"^",2))
  I SRM="",SRMM'["?" W !!,"The Drug '",SRMM,"' does not exist in your Drug file.  Please re-enter. " D RET G:SRQ END G START
@@ -42,9 +45,2 @@
 D1 I SRF=1 R !!,"ENTER DOSE: ",SRD1:DTIME S:'$T SRD1="^" K:SRD1["^" SRD Q:SRD1["^"  W:SRD1["?" !!,"Dosage must be 1 to 15 characters in length" G:SRD1["?" D1 S SRD=SRD1,SRF=0 G DOSE
  Q
-SCR(SRFL,SRPK) ; screening for fields point to the DRUG file (#50)
- N SRDT,SRN0,SRNODE,SROK,SRY S SROK=0,SRY=+Y K ^TMP($J,"SR")
- I $G(SRFL)=1 S SRTN=$S($G(SRTN):SRTN,1:DA),SRN0=$G(^SRF(SRTN,0)),SRDT=$S($P(SRN0,"^",9):$P($P(SRN0,"^",9),"."),1:DT)
- D DATA^PSS50(SRY,,$S($G(SRFL):SRDT,1:""),,,"SR")
- I SRPK="S" D  Q SROK
- .S SRNODE=$P($G(^TMP($J,"SR",SRY,63)),"^") K ^TMP($J,"SR") I SRNODE["S" S SROK=1
- S SROK=$S($P($G(^TMP($J,"SR",0)),"^")=-1:0,1:1) K ^TMP($J,"SR") Q SROK
Index: FOIAVistA/tag/r/SURGERY-SR/SROWL.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROWL.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROWL.m	(revision 636)
@@ -1,5 +1,4 @@
-SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ; 4/18/07 11:55am
- ;;3.0;Surgery;**58,119,162**;24 Jun 93;Build 4
- ;
+SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST ;13 Feb 1989  11:32 AM
+ ;;3.0;Surgery;**58,119**;24 Jun 93
 ENTER ; enter a patient on the waiting list
  S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")="  Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0)
@@ -74,6 +73,5 @@
  S SRDEMO(5)=SRDEMO(200,SRNPREC,".132")        ;Office Phone
  ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
- ; all fields except STATE will ignore input transform (SR*3.0*162)
- S DIC("DR")="1////"_SRDEMO(1)_";2////"_SRDEMO(2)_";3///"_SRDEMO(3)_";4////"_SRDEMO(4)_";5////"_SRDEMO(5)_";6////"_$P(Y,U,1)
+ S DIC("DR")="1///"_SRDEMO(1)_";2///"_SRDEMO(2)_";3///"_SRDEMO(3)_";4///"_SRDEMO(4)_";5///"_SRDEMO(5)_";6///"_$P(Y,U,1)
  S DIC(0)="Z"    ;Tells FileMan to file the data without any more user input
  Q
Index: FOIAVistA/tag/r/SURGERY-SR/SROXR4.m
===================================================================
--- FOIAVistA/trunk/r/SURGERY-SR/SROXR4.m	(revision 631)
+++ FOIAVistA/tag/r/SURGERY-SR/SROXR4.m	(revision 636)
@@ -1,4 +1,4 @@
-SROXR4 ;BIR/MAM - CROSS REFERENCES ;11/05/07
- ;;3.0; Surgery ;**62,83,100,153,166**;24 Jun 93;Build 6
+SROXR4 ;BIR/MAM - CROSS REFERENCES ;03/15/06
+ ;;3.0; Surgery ;**62,83,100,153**;24 Jun 93;Build 11
  Q
 PRO ; stuff default prosthesis info
@@ -56,18 +56,2 @@
  N SRTD,SRLO D AQDT K ^SRF("AQ",SRTD,DA)
  Q
-AT ; set logic for AT x-ref on DATE OF LAST TRANSMISSION
- N SRX S ^SRF("AT",X,DA)=""
- S SRX=$P($G(^SRF(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRF("AT",SRX,DA)
- Q
-KAT ; kill logic for AT x-ref on DATE OF LAST TRANSMISSION
- N SRX K ^SRF("AT",X,DA)
- S SRX=$P($G(^SRF(DA,"RA")),"^",4) I SRX,SRX'=X K ^SRF("AT",SRX,DA)
- Q
-AT1 ; set logic for AT x-ref on DATE TRANSMITTED
- N SRX S SRX=$P($G(^SRF(DA,"RA")),"^",8) I SRX Q
- S ^SRF("AT",X,DA)=""
- Q
-KAT1 ; kill logic for AT x-ref on DATE TRANSMITTED
- N SRX S SRX=$P($G(^SRF(DA,"RA")),"^",8)
- I SRX'=X K ^SRF("AT",X,DA)
- Q
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD1.m	(revision 636)
@@ -1,4 +1,4 @@
 TIUDD1 ; SLC/JER - XREFs for file 8925.1 ;19-OCT-2001 10:05:37 [7/28/04 9:08am]
- ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163,224**;Jun 20, 1997;Build 7
+ ;;1.0;TEXT INTEGRATION UTILITIES;**7,51,115,163**;Jun 20, 1997
 SACL(X,FLD) ; Set logic for ACL cross-reference
  ; Called from fields .01 (NAME), .07 (STATUS), .03 (PRINT NAME),
@@ -31,7 +31,6 @@
  . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
  . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
- . ;VMPELR P 224 allow the update of inactive titles
- . ; Include only TEST or ACTIVE or INACTIVE TITLES
- . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
+ . ; Include only TEST or ACTIVE titles
+ . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
  . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
  . Q:TIUTTL']""
@@ -73,6 +72,6 @@
  . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
  . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
- . ; Include only TEST or ACTIVE OR inactive titles
- . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
+ . ; Include only TEST or ACTIVE titles
+ . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
  . ; First build x-ref for Clinical Documents & Immediate descendents
  . S TIUCLASS=+$$CLINDOC^TIULC1(+TIUDA)
@@ -80,8 +79,4 @@
  . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
  . S ^TIU(8925.1,"ACL",38,X,+TIUDA)=""
- . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
- . I TIUABV]"" S TIUABV=TIUABV_"  <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)=""
- . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
- . I TIUPN]"" S TIUPN=TIUPN_"  <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)="",^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)=""
  . D SACLKWIC(X,TIUCLASS,+TIUDA)
  . ; Now build x-ref for document classes
@@ -89,9 +84,4 @@
  . I TIUCLASS'>0 Q
  . S ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)=""
- . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
- . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
- . I TIUABV]"" S TIUABV=TIUABV_"  <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)=""
- . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
- . I TIUPN]"" S TIUPN=TIUPN_"  <"_X_">" S ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)=""
  . D SACLKWIC(X,TIUCLASS,+TIUDA)
  Q
@@ -124,6 +114,6 @@
  . I $P($G(^TIU(8925.1,+TIUDA,0)),U,4)'="DOC" Q
  . S TIUSTTS=$P($G(^TIU(8925.1,+TIUDA,0)),U,7)
- . ; Include only TEST or ACTIVE or INACTIVE titles
- . I $S(TIUSTTS=10:0,TIUSTTS=11:0,TIUSTTS=13:0,1:1) Q
+ . ; Include only TEST or ACTIVE titles
+ . I $S(TIUSTTS=10:0,TIUSTTS=11:0,1:1) Q
  . S TIUTTL=$P($G(^TIU(8925.1,+TIUDA,0)),U)
  . Q:TIUTTL']""
@@ -153,5 +143,5 @@
  . D KACLKWIC(TIUTTL,TIUCLASS,+TIUDA)
  I FLD=.01 D
- . N TIUDA,TIUABV,TIUPN
+ . N TIUDA
  . S TIUDA=$S(+$G(DA(1)):+$G(DA(1)),1:+$G(DA))
  . ; First remove x-ref for Clinical Documents & Immediate descendents
@@ -159,17 +149,8 @@
  . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
  . K ^TIU(8925.1,"ACL",38,X,+TIUDA)
- . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
- . I TIUABV]"" S TIUABV=TIUABV_"  <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA),^TIU(8925.1,"ACL",38,TIUABV,+TIUDA)
- . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
- . I TIUPN]"" S TIUPN=TIUPN_"  <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA),^TIU(8925.1,"ACL",38,TIUPN,+TIUDA)
  . D KACLKWIC(X,TIUCLASS,+TIUDA)
  . ; Now remove x-ref for document classes
  . S TIUCLASS=+$$DOCCLASS^TIULC1(+TIUDA)
  . K ^TIU(8925.1,"ACL",TIUCLASS,X,+TIUDA)
- . ;VMP/ELR PATCH 224 ADDED NEXT 4 LINES
- . S TIUABV=$P($G(^TIU(8925.1,+TIUDA,0)),U,2)
- . I TIUABV]"" S TIUABV=TIUABV_"  <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUABV,+TIUDA)
- . S TIUPN=$P($G(^TIU(8925.1,+TIUDA,0)),U,3)
- . I TIUPN]"" S TIUPN=TIUPN_"  <"_X_">" K ^TIU(8925.1,"ACL",TIUCLASS,TIUPN,+TIUDA)
  . D KACLKWIC(X,TIUCLASS,+TIUDA)
  Q
@@ -180,3 +161,3 @@
  . I "(,.?! '-/&:;)"[TIUC S TIUC=$E($E(X,TIUI,TIUJ-1),1,30),TIUI=TIUJ+1
  . I  I $L(TIUC)>2 K ^TIU(8925.1,"ACL",TIUCLASS,TIUC_"  <"_X_">",TIUDA),^TIU(8925.1,"ACL",38,TIUC_"  <"_X_">",TIUDA)
- Q 
+ Q
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS ; GENERATED FROM 'TIU ENTER/EDIT DS' INPUT TEMPLATE(#1491), FILE 8925;01/12/06
+TIUEDS ; GENERATED FROM 'TIU ENTER/EDIT DS' INPUT TEMPLATE(#1491), FILE 8925;03/29/06
  D DE G BEGIN
 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS1.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS1 ; ;01/12/06
+TIUEDS1 ; ;03/29/06
  S X=DG(DQ),DIC=DIE
  I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,3)>0) S ^TIU(8925,"AA",+X,+^TIU(8925,+DA,0),(9999999-$P(+^AUPNVSIT($P(^TIU(8925,+DA,0),U,3),0),".")),+DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS10.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS10 ; ;01/12/06
+TIUEDS10 ; ;03/29/06
  D DE G BEGIN
 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS11.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS11 ; ;01/12/06
+TIUEDS11 ; ;03/29/06
  S X=DE(12),DIC=DIE
  I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS12.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS12 ; ;01/12/06
+TIUEDS12 ; ;03/29/06
  S X=DG(DQ),DIC=DIE
  I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS13.m	(revision 636)
@@ -1,1 +1,1 @@
-TIUEDS13 ; ;01/12/06
+TIUEDS13 ; ;03/29/06
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS14.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS14 ; ;01/12/06
+TIUEDS14 ; ;03/29/06
  ;;
 1 N X,X1,X2 S DIXR=247 D X1(U) K X2 M X2=X D X1("F") K X1 M X1=X
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS2.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS2 ; ;01/12/06
+TIUEDS2 ; ;03/29/06
  S X=DG(DQ),DIC=DIE
  I $P($$DOCTYPE^TIULF(+DA),U)="DOC",$L($P(^TIU(8925,+DA,0),U)),(+$P(^(0),U,2)>0) S ^TIU(8925,"AA",$P(^(0),U,2),+$P(^(0),U),(9999999-$P(+$G(^AUPNVSIT(X,0)),".")),DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS3.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS3 ; ;01/12/06
+TIUEDS3 ; ;03/29/06
  S X=DE(12),DIC=DIE
  K ^TIU(8925,"CA",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS4.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS4 ; ;01/12/06
+TIUEDS4 ; ;03/29/06
  S X=DG(DQ),DIC=DIE
  S ^TIU(8925,"CA",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS5.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS5 ; ;01/12/06
+TIUEDS5 ; ;03/29/06
  D DE G BEGIN
 DE S DIE="^TIU(8925,",DIC=DIE,DP=8925,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^TIU(8925,DA,""))=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS6.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS6 ; ;01/12/06
+TIUEDS6 ; ;03/29/06
  S X=DE(9),DIC=DIE
  I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS7.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS7 ; ;01/12/06
+TIUEDS7 ; ;03/29/06
  S X=DG(DQ),DIC=DIE
  I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS8.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS8 ; ;01/12/06
+TIUEDS8 ; ;03/29/06
  S X=DE(17),DIC=DIE
  K ^TIU(8925,"F",$E(X,1,30),DA)
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUEDS9.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUEDS9 ; ;01/12/06
+TIUEDS9 ; ;03/29/06
  S X=DG(DQ),DIC=DIE
  S ^TIU(8925,"F",$E(X,1,30),DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUFLF4.m	(revision 636)
@@ -1,4 +1,4 @@
 TIUFLF4 ; SLC/MAM - Lib; ANCESTOR(FILEDA,NODE0,ANCESTOR,DOCFLAG), ORPHAN(FILEDA,NODE0,ANCESTOR), STUFFLDS(FILEDA,PFILEDA), ADDTEN(PFILEDA,FILEDA,NODE0,TENDA),NUMITEMS(FILEDA), MISSITEM(FILEDA) ;4/23/97  11:02
- ;;1.0;TEXT INTEGRATION UTILITIES;**11,43,236**;Jun 20, 1997;Build 2
+ ;;1.0;TEXT INTEGRATION UTILITIES;**11,43**;Jun 20, 1997
  ;
 NUMITEMS(FILEDA) ; Function returns Number of Items of FILEDA; Possibly 0
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULMED.m	(revision 636)
@@ -1,4 +1,4 @@
-TIULMED ; SLC/JM,JH,AJB - Active/Recent Med Objects Routine ; 12/18/07
- ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213,238**;Jun 20, 1997;Build 6
+TIULMED ; SLC/JM,JH - Active/Recent Med Objects Routine ;1/23/07
+ ;;1.0;TEXT INTEGRATION UTILITIES;**38,73,92,94,183,193,197,198,202,213**;Jun 20, 1997;Build 3
  Q
 LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES) ;
@@ -62,9 +62,6 @@
  ;
  ; *** Scan medication data and skip unwanted meds ***
- ; Changes for *238 required by PSO*7*294
- D
- . I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE) S TIUDATE=$$FMADD^XLFDT(DT,-$G(TIUDATE)) D OCL^PSOQ0496(DFN,TIUDATE,"") Q  ; IA 2400
- . D OCL^PSOORRL(DFN,"","") ; IA 2400
  ;
+ D OCL^PSOORRL(DFN,"","") ; IA 2400
  S INDEX=0
  F  S INDEX=$O(^TMP("PS",$J,INDEX))  Q:INDEX'>0  D
@@ -81,6 +78,4 @@
  ..I ACTVONLY=2 S KEEPMED=(STATIDX=3)
  ..I +ONELIST S STATIDX=1
- ..; Changes for *238 required by PSO*7*294
- ..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0
  .I KEEPMED D
  ..S TYPE=$P($P(NODE,U),";",2)
@@ -180,5 +175,5 @@
  ;
  D SORTSAVE^TIULMED3 K @TARGET@("B"),@TARGET@("C") ;P213
-LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED"),TIUDATE ; K TIUDATE added for PSO*7*294
+LISTX K ^TMP("PS",$J),^TMP($J,"TIULMED")
  Q "~@"_$NA(@TARGET)
  ;
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIULP.m	(revision 636)
@@ -1,4 +1,4 @@
 TIULP ; SLC/JER - Functions determining privilege ;7/29/05
- ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217,236**;Jun 20, 1997;Build 2
+ ;;1.0;TEXT INTEGRATION UTILITIES;**98,100,116,109,138,152,175,157,182,184,217**;Jun 20, 1997
 CANDO(TIUDA,TIUACT,PERSON) ; Can PERSON perform action now
  ; Receives: TIUDA=Record number in file 8925
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPR200.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPR200.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPR200.m	(revision 636)
@@ -2,5 +2,5 @@
  ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997
  ;
- Q  
+ N LINE,TIUABORT,TIUCNSLT,TIUCOCOR,TIUFPRIV,TIUNAME,TIUPGNTS,TIUPRNT,TITLE,X,Y
  W !,"Verifying installation environment..."
  S TIUCOCOR=$$LU(8930,"CLINICAL COORDINATOR","X") I '+TIUCOCOR W !,"Installation Error:  CLINICAL COORDINATOR (Class Owner) cannot be defined." S TIUABORT=1
@@ -10,5 +10,5 @@
  W "complete."
  Q 
-EN Q  
+EN ;
  N LINE,TIUABORT,TIUCNSLT,TIUCOCOR,TIUFPRIV,TIUNAME,TIUPGNTS,TIUPRNT,TITLE,X,Y
  X ^%ZOSF("EON") W $G(IOCUON) W:+$L($G(IOF)) @IOF
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPR222.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPR222.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPR222.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUPR222 ; SLC/AJB - TIU Form Letter Update;06Mar07
+TIUPR222 ; SLC/AJB - TIU Form Letter Update;06Mar07 ;12/27/07  18:20
  ;;1.0;TEXT INTEGRATION UTILITIES;**222**;Jun 20, 1997
  Q
@@ -8,5 +8,5 @@
  . . I $$CHKTITLE(8925.1,NAME)>0 S TIUQUIT=1
  I +$G(TIUQUIT) W !!,"Titles have already been installed and will not be installed again." Q
- I '$D(ZTQUEUED) X ^%ZOSF("EON") W IOCUON,@IOF
+ I '$D(ZTQUEUED) X ^%ZOSF("EON") W $G(IOCUON),@IOF ;WVEHR/VOE IOCUON TO $G(IOCUON)
  I $$CHKTITLE(8925.1,"PROGRESS NOTES")<0 G EXIT
  W !!,"Creating the new DOCUMENT CLASS ""FORM LETTERS"" and"
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUPRPN8.m	(revision 636)
@@ -1,4 +1,4 @@
 TIUPRPN8 ;SLC/MAM - Print SF 509-Progress Notes, Cont ;11/10/04 [1/4/05 12:17pm]
- ;;1.0;TEXT INTEGRATION UTILITIES;**100,176,157,182,224**;Jun 20, 1997;Build 7
+ ;;1.0;TEXT INTEGRATION UTILITIES;**100,176,157,182**;Jun 20, 1997
  ;
 SIGBLK(TIUFOOT,TIUMISC,TIUCONT1,TIUCONT,TIUSIG,TIUROOT) ; Print signature block info
@@ -55,9 +55,7 @@
  . N TIUI S TIUI=0
  . S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
+ . W !?4,"Receipt Acknowledged By:"
  . F  S TIUI=$O(@TIUROOT@("EXTRASGNR",TIUI)) Q:'TIUI  D
- . . W !!?4,"Receipt Acknowledged By:"
- . . ;VMP/ELR P224 ADDED code to print awaiting signature and expected additional signer name
- . . I +$G(@TIUROOT@("EXTRASGNR",TIUI,"DATE"))'>0 D  Q
- . . . W !,?4,"* AWAITING SIGNATURE *",?30,$G(@TIUROOT@("EXTRASGNR",TIUI,"EXPNAME"))
+ . . I +$G(@TIUROOT@("EXTRASGNR",TIUI,"DATE"))'>0 Q
  . . I TIUI>1 S TIUCONT=$$SETCONT^TIUPRPN1(.TIUFOOT,TIUMISC,TIUCONT1,0,$G(TIUROOT)) Q:'TIUCONT
  . . W !?29,"/es/ ",$G(@TIUROOT@("EXTRASGNR",TIUI,"NAME"))
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUR.m	(revision 636)
@@ -1,4 +1,4 @@
 TIUR ; SLC/JER - Integrated Document Review ;11/01/03
- ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,112,207,224**;Jun 20, 1997;Build 7
+ ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,112,207**;Jun 20, 1997
  ; 11/30/00 Moved PUTLIST & ADDELMNT to TIUR1
 MAKELIST(TIUCLASS,TIUCHVW) ; Get Search Criteria
@@ -10,6 +10,5 @@
  I +$G(ORVP),(+$G(TIUCHVW)'>0) D EN^TIURPN(TIUCLASS,+ORVP) Q
 STATUS S STATUS=$$STAT
- ;VMP/ELR changed status ck from <0 TO <1 to account for entering an *  p224
- I +STATUS<1 S VALMQUIT=1 Q
+ I +STATUS<0 S VALMQUIT=1 Q
  S TIUI=0
  F  S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI!(+$G(TIUOUT))  D
@@ -148,6 +147,4 @@
  S STATUS("IFNS")=$P(TIURIDX0,U,3)
  S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4)
- ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224
- S TIUSCRN="ALL"
  D BUILD(TIUCLASS,.STATUS,.TIUSCRN,TIUEDT,TIULDT,NOWFLAG)
  ; Reexpand previously expanded items:
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURL.m	(revision 636)
@@ -1,4 +1,4 @@
 TIURL ; SLC/JER - List Management Library ;2/21/01
- ;;1.0;TEXT INTEGRATION UTILITIES;**88,100,224**;Jun 20, 1997;Build 7
+ ;;1.0;TEXT INTEGRATION UTILITIES;**88,100**;Jun 20, 1997
  ; 11/14/00 Moved UPDATEID, etc to TIURL1
  ;
@@ -22,7 +22,4 @@
  ;    rebuilt, not updated:
  I RTN="TIUROR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1
- ;VMP/ELR ADDED THE FOLLOWING 2 LINES IN PATCH 224
- I RTN="TIUR",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1
- I RTN="TIURM",$G(TIUCHNG("UPDATE")) S TIUCHNG("RBLD")=1
  ; -- Rebuild, Update, or Refresh list:
  ;    (In cases (e.g.browse) where more than one action
@@ -44,6 +41,4 @@
  . F  S TIUI=$O(ITEMS(TIUI)) Q:'TIUI  D
  . . D SETREC(TIUI,.TIUREC)
- . . ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224
- . . I $G(TIUREC)="" Q
  . . S ^TMP("TIUR",$J,TIUI,0)=TIUREC
  I $G(TIUCHNG("REFRESH")) D  Q
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIURM.m	(revision 636)
@@ -1,4 +1,4 @@
 TIURM ; SLC/JER - MIS Document Review ;9/24/03
- ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,216,224**;Jun 20, 1997;Build 7
+ ;;1.0;TEXT INTEGRATION UTILITIES;**74,79,58,100,113,216**;Jun 20, 1997
  ;12/7/00 split TIURM into TIURM & TIURM1
 MAKELIST(TIUCLASS) ; Get Search Criteria
@@ -15,6 +15,5 @@
  E  S TIUDI("ENTRIES")="ALL DIVISIONS"
 STATUS S STATUS=$S($D(TIUQUIK):$$SELSTAT^TIULA(.TIUSTAT,"F","UNSIGNED,UNCOSIGNED"),1:$$SELSTAT^TIULA(.TIUSTAT,"A",$$DFLTSTAT(DUZ)))
- ;VMP/ELR changed status ck from <0 TO <1 to account for entering an *  p224
- I +STATUS<1 S VALMQUIT=1 Q
+ I +STATUS<0 S VALMQUIT=1 Q
  S TIUI=0
  F  S TIUI=$O(TIUSTAT(TIUI)) Q:'TIUI  D
@@ -104,5 +103,5 @@
 RBLD ; Rebuild list after actions 11/30/00
  N TIUEXP,TIUR0,TIURIDX0,TIUEDT,TIULDT
- N TIURBLD,TIUI,TIUCLASS,TIUDI,TIUSCRN
+ N TIURBLD,TIUI,TIUCLASS,TIUDI
  S TIURBLD=1
  D FIXLSTNW^TIULM ;restore video for elements added to end of list
@@ -115,6 +114,4 @@
  S TIUEDT=$P(TIURIDX0,U),TIULDT=$P(TIURIDX0,U,2),NOWFLAG=+$P(TIURIDX0,U,4)
  M TIUDI=^TMP("TIUR",$J,"DIV")
- ;VMP/ELR ADDED THE FOLLOWING LINE IN PATCH 224
- S TIUSCRN="ALL"
  D BUILD(TIUCLASS,.STATUS,TIUEDT,TIULDT,NOWFLAG,.TIUDI)
  ; Reexpand previously expanded items:
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVA.m	(revision 636)
@@ -1,4 +1,4 @@
 TIUSRVA ; SLC/JER,AJB - API's for Authorization ; 03/18/04 [10/19/04 1:21pm]
- ;;1.0;TEXT INTEGRATION UTILITIES;**19,28,47,80,100,116,152,160,178,175,157,236**;Jun 20, 1997;Build 2
+ ;;1.0;TEXT INTEGRATION UTILITIES;**19,28,47,80,100,116,152,160,178,175,157**;Jun 20, 1997
  ;
  ;External reference to File ^AUPNVSIT supported by DBIA 3580
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 12/11/06
+TIUXRC ; DRIVER FOR COMPILED XREFS FOR FILE #8925 ; 12/25/06
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC1.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 12/11/06
+TIUXRC1 ; COMPILED XREF FOR FILE #8925 ; 12/25/06
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC2.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC2 ; COMPILED XREF FOR FILE #8925 ; 12/11/06
+TIUXRC2 ; COMPILED XREF FOR FILE #8925 ; 12/25/06
  ; 
  I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC3.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 12/11/06
+TIUXRC3 ; COMPILED XREF FOR FILE #8925 ; 12/25/06
  ; 
  I X'="" I +$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) K ^TIU(8925,"ASVC",+$P($G(^TIU(8925,+DA,14)),U,4),+X,+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)
@@ -37,5 +37,5 @@
  . S:$D(DIKIL) (X2,X2(1),X2(2),X2(3),X2(4))=""
  . K ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)
-CR2 S DIXR=308
+CR2 S DIXR=413
  K X
  S DIKZ(12)=$G(^TIU(8925,DA,12))
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 12/11/06
+TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 12/25/06
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC5.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC5.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC5.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC5 ; COMPILED XREF FOR FILE #8925 ; 12/11/06
+TIUXRC5 ; COMPILED XREF FOR FILE #8925 ; 12/25/06
  ; 
  I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,13)),U) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+X,(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""
Index: FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC6.m
===================================================================
--- FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC6.m	(revision 631)
+++ FOIAVistA/tag/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC6.m	(revision 636)
@@ -1,3 +1,3 @@
-TIUXRC6 ; COMPILED XREF FOR FILE #8925 ; 12/11/06
+TIUXRC6 ; COMPILED XREF FOR FILE #8925 ; 12/25/06
  ; 
  I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
@@ -70,5 +70,5 @@
  . K X1,X2 M X1=X,X2=X
  . S ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)=""
-CR2 S DIXR=308
+CR2 S DIXR=413
  K X
  S DIKZ(12)=$G(^TIU(8925,DA,12))
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDSHOW.m	(revision 636)
@@ -1,4 +1,4 @@
-XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;01/30/2008
- ;;7.3;TOOLKIT;**23,49,78,112**;Apr 25, 1995;Build 1
+XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;02/11/2004  08:56
+ ;;7.3;TOOLKIT;**23,49,78**;Apr 25, 1995
  ;;
 SHOW(FILE,REC1,REC2,FLDS,REVIEW) ;
@@ -49,7 +49,5 @@
  . . . S XN=$P(DDVAL,U)
  . . . S XDRA=0
- . . . I X1'=""&(X2'=""),X1'=X2 D
- . . . . I FILE=2,((FLD=991.01)!(FLD=991.02)) Q  ;jds restrict ICN overwrites for MPI 
- . . . . S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1
+ . . . I X1'=""&(X2'=""),X1'=X2 S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1
  . . . I 'REVIEW!XDRA D
  . . . . W ! S NLIN=NLIN-1
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMKPCF.m	(revision 636)
@@ -1,4 +1,4 @@
-XTPMKPCF ;OAK/BP - COMPUTED FIELDS AND OTHER ODDITIES FOR PATCH MONITOR;
- ;;7.3;TOOLKIT;**98,106**; Apr 25, 1995;Build 1
+XTPMKPCF ;OAK/BP - COMPUTED FIELDS AND OTHER ODDITIES FOR PATCH MONITOR; [8/9/05 9:23am]
+ ;;7.3;TOOLKIT;**98**; Apr 25, 1995
  ;
  ; computed fields
@@ -8,8 +8,7 @@
  ;   patches may be involved.  If a test patch, null the pointer, like nothing is there.
  S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X=""
- S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" Q
+ S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X=""
  S X=$P($G(^XPD(9.7,+X,1)),U,3)
- I X="" Q
- S Y=X D DD^%DT S X=$P(Y,"@") K Y
+ S X=$E(X,1,7)
  Q
  ;
@@ -70,10 +69,2 @@
  K XTBX1,XTBZ,NIGHT,XTBCMPDT,ZTSK,ZTIO,ZTRTN,ZTSAVE
  Q
- ;
-INSDATE ;Print out Installed Date
- N X,X1
- S X=$P($G(^XPD(9.9,D0,0)),U,8) Q:X=""
- S X1=$P($G(^XPD(9.9,D0,0)),U,11) I X1>0 W $$FMTE^XLFDT(X1,"2Z") Q
- S X=$O(^XPD(9.7,"B",X,9999999999),-1) I $G(^XPD(9.7,+X,2))["TEST v" S X="" Q
- S X=$P($G(^XPD(9.7,+X,1)),U,3) W $$FMTE^XLFDT($P(X,"."),"2Z")
- Q
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XTPMSTA2.m	(revision 636)
@@ -1,4 +1,4 @@
-XTPMSTA2 ;OAK/BP - PRINT PATCH STATISTICS BY COMPLIANCE DATE;
- ;;7.3;TOOLKIT;**98,100,106**; Apr 25, 1995;Build 1
+XTPMSTA2 ;OAK/BP - PRINT PATCH STATISTICS BY COMPLIANCE DATE; [1/4/06 9:33am]
+ ;;7.3;TOOLKIT;**98,100**; Apr 25, 1995;Build 4
  ;
  S IOP="HOME" D ^%ZIS K IOP
@@ -39,5 +39,5 @@
  ..I XTBINSDT]"" S X1=XTBINSDT,X2=XTBCPLDT D ^%DTC S XTBDAYLT=X
  ..I XTBINSDT="" S X1=DT,X2=XTBCPLDT D ^%DTC S XTBDAYLT=X
- ..S Y=XTBINSDT X ^DD("DD") I Y'="" S XTBINSDT=$P(Y,",",1)_","_$E($P(Y,",",2),2,5) ;set date format "MON DD,YYYY"
+ ..S Y=XTBINSDT X ^DD("DD") S XTBINSDT=Y
  ..S Y=XTBCPLDT X ^DD("DD") S XTBCPLDX=Y
  ..S Y=XTBRELDT X ^DD("DD") S XTBRELDT=Y
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT01.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT01.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT01.m	(revision 636)
@@ -1,3 +1,3 @@
-XUCT01 ; GENERATED FROM 'XUSERINQ' PRINT TEMPLATE (#27) ; 12/12/07 ; (FILE 200, MARGIN=80)
+XUCT01 ; GENERATED FROM 'XUSERINQ' PRINT TEMPLATE (#27) ; 12/27/07 ; (FILE 200, MARGIN=80)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT011.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT011.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT011.m	(revision 636)
@@ -1,3 +1,3 @@
-XUCT011 ; GENERATED FROM 'XUSERINQ' PRINT TEMPLATE (#27) ; 12/12/07 ; (continued)
+XUCT011 ; GENERATED FROM 'XUSERINQ' PRINT TEMPLATE (#27) ; 12/27/07 ; (continued)
  G BEGIN
 N W !
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT03.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT03.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT03.m	(revision 636)
@@ -1,3 +1,3 @@
-XUCT03 ; DRIVER FOR COMPILED XREFS FOR FILE #3.081 ; 10/15/04
+XUCT03 ; DRIVER FOR COMPILED XREFS FOR FILE #3.081 ; 01/30/05
  ; 
  N DH,DU,DIKILL,DISET,DIKJ,DIKZ,DIKYR,DIKZA,DIK0Z,DIKZK,DIKDP,DIKM1,DIKUP,DIKUM,DV,DIIX,DIKF,DIAU,DIKNM,DIKDA,DIKLK,DIKLM,DIKY,DIXR,DIKCOND,DIKSVDA,DIKPUSH,X1,X2
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT031.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT031.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT031.m	(revision 636)
@@ -1,3 +1,3 @@
-XUCT031 ; COMPILED XREF FOR FILE #3.081 ; 10/15/04
+XUCT031 ; COMPILED XREF FOR FILE #3.081 ; 01/30/05
  ; 
  S DIKZK=2
Index: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT032.m
===================================================================
--- FOIAVistA/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT032.m	(revision 631)
+++ FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XUCT032.m	(revision 636)
@@ -1,3 +1,3 @@
-XUCT032 ; COMPILED XREF FOR FILE #3.081 ; 10/15/04
+XUCT032 ; COMPILED XREF FOR FILE #3.081 ; 01/30/05
  ; 
  S DIKZK=1
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m	(revision 636)
@@ -1,7 +1,7 @@
-DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;9APR2007
- ;;22.0;VA FileMan;**89,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;02:13 PM  24 Dec 2001
+ ;;22.0;VA FileMan;**89**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  S T=$E(Z) G CHECK^DICATT:$D(DTOUT)
- F P="I","O","L","x" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2)
+ F P="I","O","L" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2)
 1 K DS S:$P(Z,U)'["K" V=W[";0"
  S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N"
@@ -21,19 +21,9 @@
  ;
 W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN
- G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"L"),U)_$E("L",%=2)_U G WINDOW
- W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT"
+ G CHECK^DICATT:%<0 I % S Z=$P($P(Z,"L")_$P(Z,"L",2),U)_$E("L",%=2)_U G G
+ W !?3,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT"
  W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES."
  W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT"
  W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W
- ;
- ;
-WINDOW S %=2-(Z["x"!'O) W !,"SHALL ""|"" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS" D YN^DICN
- G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"x"),U)_$E("x",%=1)_U G G
- W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT MAY HAVE ""|"" CHARACTERS"
- W !?3,"IN IT (SUCH AS HL7 MESSAGES) THAT NEED TO DISPLAY EXACTLY AS THEY ARE STORED."
- W !,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT WITH ANYTHING"
- W !?3,"THAT IS DELIMITED BY ""|"" CHARACTERS INTERPRETED AS VARIABLE TEXT.",! G WINDOW
- ;
- ;
  ;
 X ;
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m	(revision 636)
@@ -1,4 +1,4 @@
-DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;5NOV2007
- ;;22.0;VA FileMan;**6,76,114,144,152**;;Build 10
+DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2DEC2006
+ ;;22.0;VA FileMan;**6,76,114,144**;;Build 5
  ;Per VHA Directive 2004-038, this routine should not be modified.
  N DICOMPI
@@ -6,5 +6,5 @@
 LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q
 L S T=DLV,DICN=X
-TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$G(^DD(J(T),.01,0))="",UP:$P(^(0),U,2)["W" S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" "
+TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$D(^DD(J(T)))<9 S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" "
  S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0"
  D DICS^DICOMPY:DUZ(0)'="@"
@@ -13,5 +13,5 @@
 N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R
 NUMBER I X="NUMBER" S Y=.001,Y(0)=0 G D
-UP S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1))
+ S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1))
  ;
 A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D  S W=$E(I,D+1)
@@ -31,6 +31,5 @@
 S ;
  S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S"))
-OUT I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D  Q
- .S X="$$EXTERNAL^DIDU("_T_","_DICN_","""","_X_")",DICO("DIERR")=1
+ I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D DIMP^DICOMPZ("N C S Y="_X_",C="""_D_""" D:$D(^DD("_T_","_DICN_",0)) Y^DIQ") S X=X_" S X=Y" Q
 SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))"
  Q:D'["P"  S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2)
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m	(revision 636)
@@ -1,5 +1,5 @@
-DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;19JUNE2007
- ;;22.0;VA FileMan;**6,44,76,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;12:45 PM  9 Sep 2002
+ ;;22.0;VA FileMan;**6,44,76**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  F  Q:'$D(DPS(DPS,"ST"))  D DPS^DICOMPW S K=K+1,K(K)=X
  G 0:DPS
@@ -40,5 +40,5 @@
  S DICOMP="",DLV=DICO(1)
 Q I DICOMP'["S" S K=DICO(1) F  S K=$O(I(K)) Q:K=""  K I(K),J(K)
- I $D(X) S:$D(DICO("DIERR")) X="N DIERR "_X I $G(DICOMPQI) S X="N Y "_X
+ I $G(DICOMPQI),$D(X) S X="N Y "_X
 Y K Y I $D(DICO("RCR")) S Y=DICO("RCR")
  E  S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2)))
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m	(revision 636)
@@ -1,5 +1,5 @@
-DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;9APR2007
- ;;22.0;VA FileMan;**6,76,114,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;05:07 PM  16 Jan 2003
+ ;;22.0;VA FileMan;**6,76,114**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  ;
 PRIOR ;from DICOMP -- PRIOR.. Functions get archived values
@@ -41,5 +41,4 @@
  S DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D)  S D=D"_Y
  S DICOR=$$REF(T)_","_D_",",D="F D=0:0 S (D,D"_Y_")=$O("_DICOR
- I W=")",$D(DPS(DPS,"INTERNAL")) S D="S D=$G(DIWF) N DIWF S DIWF=D_""XL"" "_D ;**DI*22*152
  S %=+$P(DICOT,U,2)
  I $P($G(^DD(%,.01,0)),U,2)["W"!'$D(^DD(%,0,"IX","B",%,.01))
@@ -55,5 +54,5 @@
  ;
 CONTAINS N DICON
- S DICON=W="'",%=$E(I,M+DICON) I %=""!(W=")") S Y=0 Q
+ S DICON=W="'",%=$E(I,M+DICON) I %="" S Y=0 Q
  I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y)  D  Q
  .S DICOXR=$$DGI^DICOMP
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DID1.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DID1.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DID1.m	(revision 636)
@@ -1,5 +1,5 @@
-DID1 ;SFISC/XAK,JLT-STD DD LIST ;9APR2007
- ;;22.0;VA FileMan;**7,76,105,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DID1 ;SFISC/XAK,JLT-STD DD LIST ;1:53 PM  6 Mar 2002
+ ;;22.0;VA FileMan;**7,76,105**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  S DJ(Z)=D0,DDL1=14,DDL2=32 G B
  ;
@@ -9,8 +9,5 @@
  D HD:$Y+6>IOSL Q:M=U  W !!,F(Z),",",DJ(Z)
  W ?(Z+Z+12),$P(N,U,1),?DDL2+4," "_$P(N,U,4)
- S X=$P(N,U,2)
-WP I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" D
- .S X="WORD-PROCESSING #"_+X D  S X="(NOWRAP)" D:W["L"  S X="(IGNORE ""|"")" D:W["X"!(W["x")  S X="(UNEDITABLE)" D:W["I"  S X=""
- ..W:$L(X)+$X+5>IOM !?18 W "   ",X
+ S X=$P(N,U,2) I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" W "   WORD-PROCESSING #",+X W:W["L" " (NOWRAP)" S X=""
  F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" W ?40," "_W G ND:M=U
  I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m	(revision 636)
@@ -1,11 +1,9 @@
-DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;5APR2007
- ;;22.0;VA FileMan;**152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;11/20/92  09:28
+ ;;22.0;VA FileMan;;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
 DOWN ;
- I W>0,'$D(^DD(DP,+W,0)) Q  ;IN CASE FIELD IS GONE FOR SOME REASON!
- S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI G F:W'>0 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";") S:+DU'=DU DU=""""_DU_""""
- S W=$P(W,","),DY="D"_(DIL-DIL0+1),DI=DI_","_DU_","_DY,%=":0 Q:$O("_DI_"))'>0 ",DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP,Y=" S "_DY_"=$O(^("_DY_"))"
-W I $P(^DD(DP,.01,0),U,2)["W" D:$P(^(0),U,2)["x"!($P(^(0),U,2)["X")  G P ;**DI*22*152**
- .S D=D_",D"_(DIL+1)_"=$G(DIWF) N DIWF S DIWF=D"_(DIL+1)_"_""X"""
+ S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI G F:W'>0 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";",1) S:+DU'=DU DU=""""_DU_""""
+ S W=$P(W,C,1),DY="D"_(DIL-DIL0+1),DI=DI_C_DU_C_DY,%=":0 Q:$O("_DI_"))'>0 ",DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP,Y=" S "_DY_"=$O(^("_DY_"))"
+ G P:$P(^DD(DP,.01,0),U,2)["W"
  I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP))
 DPP S %=%_" X:$D(DSC("_DP_")) DSC("_DP_")",Y=Y_" Q:"_DY_"'>0" I $T,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F"))
@@ -22,7 +20,7 @@
 QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT
  S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP
- S X=" "_$P($P(W,U,4,99),";")
+ S X=" "_$P($P(W,U,4,99),";",1)
  S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL
- S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=","_%_X
+ S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=C_%_X
  I DHT=-1 D DREL^DIPZ1 G END
  F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I  D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m	(revision 636)
@@ -1,5 +1,5 @@
-DINIT0F0 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;4APR2007
- ;;22.0;VA FileMan;**152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DINIT0F0 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;10:49 AM  30 Mar 1999
+ ;;22.0;VA FileMan;;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  D PRE^DINIT29P
  F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F1 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
@@ -139,5 +139,5 @@
  ;;=.00104^1^1,1^e
  ;;^DIST(.403,.001,40,7,0)
- ;;=2.5^^4,2^^^1^8,78
+ ;;=2.5^^4,6^^^1^6,75
  ;;^DIST(.403,.001,40,7,1)
  ;;=Page 2.5
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m	(revision 636)
@@ -1,5 +1,5 @@
-DINIT0F5 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;9APR2007
- ;;22.0;VA FileMan;**76,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
+DINIT0F5 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;05:51 PM  23 Mar 2001
+ ;;22.0;VA FileMan;**76**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F6 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y
  Q
@@ -144,9 +144,9 @@
  ;;=DICATT5^1
  ;;^DIST(.404,.00105,40,0)
- ;;=^.4044I^2^2
+ ;;=^.4044I^1^1
  ;;^DIST(.404,.00105,40,1,0)
  ;;=75^SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE^2^^WORD-WRAP
  ;;^DIST(.404,.00105,40,1,2)
- ;;=2,53^3^2,2
+ ;;=2,56^3^2,5
  ;;^DIST(.404,.00105,40,1,3)
  ;;=!M
@@ -154,5 +154,5 @@
  ;;=S Y=$E("YN",DICATT2["L"+1)
  ;;^DIST(.404,.00105,40,1,12)
- ;;=S DICATTMN="",DICATT2N="W"_$TR($G(DICATT2N),"WL")_$E("L",'X)
+ ;;=S DICATTMN="" S:'X DICATT2N="WL" I DUZ(0)="@",DICATT4="" S DDSSTACK=4
  ;;^DIST(.404,.00105,40,1,20)
  ;;=Y
@@ -167,26 +167,4 @@
  ;;^DIST(.404,.00105,40,1,21,4,0)
  ;;=it was entered.
- ;;^DIST(.404,.00105,40,2,0)
- ;;=76^SHALL "|" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS^2^^"|"
- ;;^DIST(.404,.00105,40,2,2)
- ;;=3,74^3^3,2
- ;;^DIST(.404,.00105,40,2,3)
- ;;=!M
- ;;^DIST(.404,.00105,40,2,3.1)
- ;;=S Y=$S(DICATT2["X"!(DICATT2["x")!(DICATT2=""):"Y",1:"N")
- ;;^DIST(.404,.00105,40,2,12)
- ;;=S DICATTMN="",DICATT2N="W"_$TR($G(DICATT2N),"WxX")_$E("x",X>0) I DUZ(0)="@",DICATT4="" S DDSSTACK=4
- ;;^DIST(.404,.00105,40,2,20)
- ;;=Y
- ;;^DIST(.404,.00105,40,2,21,0)
- ;;=^^4^4^2981120
- ;;^DIST(.404,.00105,40,2,21,1,0)
- ;;=Answer 'YES' if the internally-stored text may have "|" characters in it 
- ;;^DIST(.404,.00105,40,2,21,2,0)
- ;;=(such as HL7 messages) that need to display exactly as they are stored.
- ;;^DIST(.404,.00105,40,2,21,3,0)
- ;;=Answer 'NO' if the internal text should normally be printed out with
- ;;^DIST(.404,.00105,40,2,21,4,0)
- ;;=anything that is delimited by "|" characters interpreted as variable. 
  ;;^DIST(.404,.00106,0)
  ;;=DICATT6^1
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m	(revision 636)
@@ -1,25 +1,5 @@
-DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;10JUN2005
- ;;22.0;VA FileMan;**46,152**;Mar 30, 1999;Build 10
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;The DIWF variable contains a string of one-letter codes to control W-P output.
- ;"|" in DIWF means that "|"-windows are not to be evaluated, but are to be printed as
- ;     they stand.
- ;"X" means eXactly line-for-line, with "||" printed as "||"
- ;"W" in DIWF means that formatted text will be written out to
- ;     the current device as it is assembled.
- ;"N" means NOWRAP-- text is assembled line-for-line
- ;"R" means text will be assembled Right-justified
- ;"D" means text will be double-spaced
- ;"L" means internal line numbers appear at the left margin
- ;"C" followed by a number will cause formatting of text in a column
- ;     width specified by the number.
- ;"I" followed by a number will cause text to be indented that number
- ;     of columns.
- ;"?" means that, if user's terminal is available, "|"-windows that cannot
- ;     be evaluated will be asked from the user's terminal.
- ;"B" followed by number causes new page when output gets within that
- ;   number of lines from the bottom of the page (as defined by IOSL).
- ;   
- ;DIWTC is a Boolean -- Are we printing out in LINE MODE?
+DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;12:15 PM  5 Jun 2000
+ ;;22.0;VA FileMan;**46**;Mar 30, 1999
+ ;Per VHA Directive 10-93-142, this routine should not be modified.
  S:'$L(X) X=" "
  S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1
@@ -29,6 +9,5 @@
  D NEW:DIWTC
 Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z
-DIW ;from RCR+5^DIWW
- I DIWF["X" S DIWTC=1,X=DIWX,DIWX="" D C G D ;**DI*22*152**  Leave line unaltered
+DIW ;
  S X=$P(DIWX,DIW,1) D C:X]"" S X=$P(DIWX,DIW,1),DIWX=$P(DIWX,DIW,2,999) G D:DIWX="" I $D(DIWP),X'?.E1" " D ST
  S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N
Index: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m
===================================================================
--- FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m	(revision 631)
+++ FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m	(revision 636)
@@ -1,4 +1,4 @@
-DIWW ;SFISC/GFT-OUTPUT WP LINE ;5NOV2007
- ;;22.0;VA FileMan;**64,144,152**;Mar 30, 1999;Build 10
+DIWW ;SFISC/GFT-OUTPUT WP LINE ;02:59 PM  18 Apr 2002
+ ;;22.0;VA FileMan;**64,144**;Mar 30, 1999;Build 5
  ;Per VHA Directive 2004-038, this routine should not be modified.
  F I=0:1 G:$D(DN) QQ:'DN Q:$D(^UTILITY($J,"W"))<9  D T G:$D(DN) QQ:'DN D 0
@@ -48,5 +48,5 @@
  ;
 DIQ ;
- S DIWF=$E("N",C["L")_"W"_$E("|X",C["X"!(C["x")+1),DIWL=2,DIWR=IOM,X=O_":   " K ^UTILITY($J,"W")
+ S DIWF=$E("N",C["L")_"W|",DIWL=2,DIWR=IOM,X=O_":   " K ^UTILITY($J,"W")
  S W=0 F  D  S W=$O(@(D(DL-1)_"W)")) Q:W'>0!(S=0)  S X=^(W,0)
  .D ^DIWP
Index: FOIAVistA/tag/r/VENDOR_AMA-VACPT/VACPT.m
===================================================================
--- FOIAVistA/trunk/r/VENDOR_AMA-VACPT/VACPT.m	(revision 631)
+++ FOIAVistA/tag/r/VENDOR_AMA-VACPT/VACPT.m	(revision 636)
@@ -1,4 +1,4 @@
 VACPT ;ALB/GRR - DISPLAY CPT COPYRIGHT INF ; 12 APR 1989@1400
- ;;5.3;Registration;**123,124,138**;Aug 13, 1993
+ ;;5.3;Registration;**123,124,138**;Aug 13, 1993;Build 1
  ;
  ;  This routine now calls the CPT api for displaying the
Index: FOIAVistA/tag/r/VISTALINK-XOBV/XOBVSKT.m
===================================================================
--- FOIAVistA/trunk/r/VISTALINK-XOBV/XOBVSKT.m	(revision 631)
+++ FOIAVistA/tag/r/VISTALINK-XOBV/XOBVSKT.m	(revision 636)
@@ -1,4 +1,4 @@
-XOBVSKT ;; mjk/alb - VistaLink Socket Methods ; 07/27/2002  13:00
- ;;1.5;VistALink;;Sep 09, 2005
+XOBVSKT ;; mjk/alb - VistaLink Socket Methods ;9/13/07  17:11
+ ;;1.5;VistALink;;Sep 09, 2005;Build 2
  ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
  ;
@@ -76,5 +76,5 @@
 RMORE(LEN,XOBUF) ;
  NEW X
- READ X#LEN:1 SET XOBUF=XOBUF_X
+ READ X#LEN:1 SET XOBUF=XOBUF_X I $DEVICE S $P(XOBUF," ",LEN)=""
  QUIT
  ;
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;04/10/06
+A1CKC ; GENERATED FROM 'A1CK VARO/DHCP' INPUT TEMPLATE(#1505), FILE 2;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -200,5 +200,5 @@
 C7S S X="" G:DG(DQ)=X C7F1 K DB
  D ^A1CKC2
-C7F1 N X,X1,X2 S DIXR=643 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
+C7F1 N X,X1,X2 S DIXR=664 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^DPT("APTYPE",X,DA)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC1.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC1 ; ;04/10/06
+A1CKC1 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC10.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC10 ; ;04/10/06
+A1CKC10 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC11.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC11 ; ;04/10/06
+A1CKC11 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC12.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC12 ; ;04/10/06
+A1CKC12 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(D0,.372,",DIC=DIE,DP=2.04,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^DPT(D0,.372,DA,""))=""
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC13.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC13 ; ;04/10/06
+A1CKC13 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC14.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC14 ; ;04/10/06
+A1CKC14 ; ;04/21/06
  S X=DE(15),DIC=DIE
  X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC15.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC15 ; ;04/10/06
+A1CKC15 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC2.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC2 ; ;04/10/06
+A1CKC2 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC3.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC3 ; ;04/10/06
+A1CKC3 ; ;04/21/06
  D DE G BEGIN
 DE S DIE="^DPT(",DIC=DIE,DP=2,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^DPT(DA,""))=""
@@ -214,5 +214,5 @@
 C7S S X="" G:DG(DQ)=X C7F1 K DB
  D ^A1CKC10
-C7F1 N X,X1,X2 S DIXR=643 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
+C7F1 N X,X1,X2 S DIXR=664 D C7X1(U) K X2 M X2=X D C7X1("O") K X1 M X1=X
  I $G(X(1))]"" D
  . K ^DPT("APTYPE",X,DA)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC4.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC4 ; ;04/10/06
+A1CKC4 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36205,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(2,.36205,1,1,1.4)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC5.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC5 ; ;04/10/06
+A1CKC5 ; ;04/21/06
  S X=DE(5),DIC=DIE
  X ^DD(2,.36215,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,2.4)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC6.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC6 ; ;04/10/06
+A1CKC6 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X ^DD(2,.36215,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DPT(D0,.362)):^(.362),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(2,.36215,1,1,1.4)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC7.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC7 ; ;04/10/06
+A1CKC7 ; ;04/21/06
  S X=DE(6),DIC=DIE
  ;
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC8.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC8 ; ;04/10/06
+A1CKC8 ; ;04/21/06
  S X=DG(DQ),DIC=DIE
  X "S DFN=DA D EN^DGMTR K DGREQF"
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/A1CKC9.m	(revision 636)
@@ -1,3 +1,3 @@
-A1CKC9 ; ;04/10/06
+A1CKC9 ; ;04/21/06
  S X=DE(7),DIC=DIE
  I ($T(AVAFC^VAFCDD01)'="") S VAFCF="391;" D AVAFC^VAFCDD01(DA)
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGADTP2.m	(revision 636)
@@ -1,4 +1,4 @@
 RGADTP2 ;BIR/DLR-ADT PROCESSOR TO RETRIGGER A08 or A04 MESSAGES WITH AL/AL (COMMIT/APPLICATION) ACKNOWLEDGEMENTS - CONTINUED ;10/30/02  10:04
- ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48,49**;30 Apr 99;Build 1
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**27,20,45,44,47,48**;30 Apr 99;Build 3
 DBIA ;
  ;Reference to $$ADD^VAFCEHU1 supported by IA #2753
@@ -53,5 +53,5 @@
  ..S ARRAY(.2403)=$$FREE^RGRSPARS($G(ARRAY("MMN"))),ARRAY(991.01)=$P($G(ARRAY("ICN")),"V")
  ..N ARAY M ARAY(2)=ARRAY
- ..S VAFCA08=1  ;S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY") comment out by RG*1*49
+ ..S VAFCA08=1 S BOGUS=$$ADD^VAFCEHU1(VAFCA,"ARAY")
  .;if sending site is the CMOR OR MPI - synchronize data **45 ADDED MPI AND SSNV TO UPDATED FIELDS
  .I (OTHSITE)=(CMOR)!(OTHSITE="200M") D
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVMPI.m	(revision 636)
@@ -1,4 +1,4 @@
 RGPVMPI ;BIR/PTD-REMOTE PRIMARY VIEW DISPLAY FROM MPI ;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 EN1^XWB2HL7 supported by IA #3144
@@ -33,15 +33,15 @@
  .D FULL^VALM1
 NOQ ;No previous query exists for this ICN
- I '$D(^XTMP("RGPVMPI"_RGICN)) D RPC G DISP
+ I '$D(^XTMP("RGPVMPI",RGICN)) D RPC G DISP
  ;
 OLDQ ;Query previously sent for this ICN
- I $D(^XTMP("RGPVMPI"_RGICN)) D
- .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVMPI"_RGICN,"DATA"),"^",2))
+ I $D(^XTMP("RGPVMPI",RGICN)) D
+ .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVMPI",RGICN),"^",2))
  .W !,"A query was last sent for this ICN on "_SNTDT
  .;Has data returned for query?
- .S RETURN(0)=$P(^XTMP("RGPVMPI"_RGICN,"DATA"),"^")
+ .S RETURN(0)=$P(^XTMP("RGPVMPI",RGICN),"^")
  .D RPCCHK^XWB2HL7(.RESULT,RETURN(0))
  .;Data has NOT returned
- .I +RESULT(0)'=1 D FAIL  Q  ;**53
+ .I +RESULT(0)'=1 S QUIT=1 W !,"Query data has NOT returned from the MPI; please check back later." Q
  .I +RESULT(0)=1 D  ;Data has returned
  ..S DIR("A")="Do you wish to view the existing query data now? ",DIR(0)="YA"
@@ -50,5 +50,5 @@
  ..I Y>0 K DIR Q  ;yes, use existing query
  ..I Y=0 D  Q  ;no, don't use existing, send new query
- ...K ^XTMP("RGPVMPI"_RGICN)
+ ...K ^XTMP("RGPVMPI",RGICN)
  ...D RPC
  ...K DIR
@@ -70,10 +70,13 @@
  W !,"This will take some time; please be patient."
  D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW FROM MPI",1,RGICN) I RETURN(0)'="" D  Q
- .S ^XTMP("RGPVMPI"_RGICN,0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW MPI PDAT"
- .S ^XTMP("RGPVMPI"_RGICN,"DATA")=RETURN(0)_"^"_$$NOW^XLFDT
+ .S ^XTMP("RGPVMPI",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW MPI PDAT"
+ .S ^XTMP("RGPVMPI",RGICN)=RETURN(0)_"^"_$$NOW^XLFDT
  .;Has data returned for this query?
  .S CNT=0 F  S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0)  H 2 I CNT>15 Q  ;result(0)=status of handle
  .I +RESULT(0)=1 W !,"Query data has returned from the MPI and is available for review."
- .I +RESULT(0)'=1 D FAIL  ;**53
+ .I +RESULT(0)'=1 D  ;quit, info not back after 30 seconds
+ ..W !,"Query data has NOT returned from the MPI; please check back later."
+ ..S QUIT=1
+ ..I SAPV=0 D PAUSE^VALM1
  W !!,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1))
  S QUIT=1
@@ -81,10 +84,2 @@
  Q
  ;
-FAIL ;Status of RPC call - unsuccessful after 30 seconds ;**53
- W !,"Your query request has NOT returned data from the MPI after trying for"
- W !,"30 seconds. This could be due to network issues. Please try again later."
- K ^XTMP("RGPVMPI"_RGICN)
- S QUIT=1
- I SAPV=0 D PAUSE^VALM1
- Q
- ;
Index: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m
===================================================================
--- FOIAVistA/trunk/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m	(revision 631)
+++ FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGPVREJ.m	(revision 636)
@@ -1,4 +1,4 @@
 RGPVREJ ;BIR/PTD-REMOTE PRIMARY VIEW REJECT (PATIENT) ;10/8/06
- ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,47,53**;30 Apr 99;Build 2
+ ;;1.0;CLINICAL INFO RESOURCE NETWORK;**44,47**;30 Apr 99;Build 10
  ;
  ;Reference to ^XWB2HL7 supported by IA #3144
@@ -24,13 +24,13 @@
  S RGEDT=$$DT^XLFDT ;End date for report internal format
 NOQ ;No previous query exists for this ICN/exception date
- I '$D(^XTMP("RGPVREJ"_RGICN,RGBDT)) D RPC G DISP
+ I '$D(^XTMP("RGPVREJ",RGICN,RGBDT)) D RPC G DISP
  ;
 OLDQ ;Query already sent for this ICN/ exception date
- I $D(^XTMP("RGPVREJ"_RGICN,RGBDT)) D
- .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVREJ"_RGICN,RGBDT),"^",2))
+ I $D(^XTMP("RGPVREJ",RGICN,RGBDT)) D
+ .S SNTDT=$$FMTE^XLFDT($P(^XTMP("RGPVREJ",RGICN,RGBDT),"^",2))
  .W !?3,"A query was last sent for this ICN/Exception Date on "_SNTDT
  .S X=$P(SNTDT,"@") D ^%DT S SNTDT=Y ;convert to internal, strip time
  .;Has data returned for existing query?
- .S RETURN(0)=$P(^XTMP("RGPVREJ"_RGICN,RGBDT),"^")
+ .S RETURN(0)=$P(^XTMP("RGPVREJ",RGICN,RGBDT),"^")
  .D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) I +RESULT(0)=1 D  Q  ;Data has returned
  ..I RGEDT=SNTDT D  ;query was sent 'today', want to use that one?
@@ -40,5 +40,5 @@
  ...I Y>0 K DIR Q  ;yes, use existing query
  ...I Y=0 D  Q  ;no, don't use existing, send new query
- ....K ^XTMP("RGPVREJ"_RGICN,RGBDT)
+ ....K ^XTMP("RGPVREJ",RGICN,RGBDT)
  ....D RPC
  ....K DIR
@@ -46,8 +46,8 @@
  ..I RGEDT'=SNTDT D  ;query was NOT sent 'today', data may be old, send new query
  ...W !?3,"Previous Query data may be obsolete."
- ...K ^XTMP("RGPVREJ"_RGICN,RGBDT)
+ ...K ^XTMP("RGPVREJ",RGICN,RGBDT)
  ...D RPC
  .;Data for existing query has NOT returned  **47
- .I +RESULT(0)'=1 D FAIL  ;**53
+ .I +RESULT(0)'=1 S QUIT=1 W !?3,"Query data has NOT returned from the MPI; please check back later." D PAUSE^VALM1
  ;
 DISP ;Display Primary View Reject Data
@@ -61,10 +61,13 @@
  W !?3,"This will take some time; please be patient."
  D EN1^XWB2HL7(.RETURN,"200M","RG PRIMARY VIEW REJECT",1,RGSITE,RGICN,RGBDT,RGEDT) I RETURN(0)'="" D  Q
- .S ^XTMP("RGPVREJ"_RGICN,0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW REJECT"
- .S ^XTMP("RGPVREJ"_RGICN,RGBDT)=RETURN(0)_"^"_$$NOW^XLFDT
+ .S ^XTMP("RGPVREJ",0)=$$FMADD^XLFDT(DT,2)_"^"_DT_"^"_"PRIMARY VIEW REJECT"
+ .S ^XTMP("RGPVREJ",RGICN,RGBDT)=RETURN(0)_"^"_$$NOW^XLFDT
  .;Has data returned for this query?
  .S CNT=0 F  S CNT=CNT+1 D RPCCHK^XWB2HL7(.RESULT,RETURN(0)) Q:RESULT(0)  H 2 I CNT>15 Q  ;result(0)=status of handle
  .I +RESULT(0)=1 W !?3,"Query data has returned from the MPI and is available for review."
- .I +RESULT(0)'=1 D FAIL  ;**53
+ .I +RESULT(0)'=1 D  ;quit, info not back after 30 seconds
+ ..W !?3,"Query data has NOT returned from the MPI; please check back later."
+ ..S QUIT=1
+ ..D PAUSE^VALM1
  W !!?3,"Problem with Query: ",RETURN(0)_"^"_$G(RETURN(1))
  S QUIT=1
@@ -72,10 +75,2 @@
  Q
  ;
-FAIL ;Status of RPC call - unsuccessful after 30 seconds ;**53
- W !?3,"Your query request has NOT returned data from the MPI after trying for"
- W !?3,"30 seconds. This could be due to network issues. Please try again later."
- K ^XTMP("RGPVREJ"_RGICN,RGBDT)
- S QUIT=1
- D PAUSE^VALM1
- Q
- ;
