APCHSM ; IHS/CMI/LAB - HEALTH SUMMARY (MULTIPLE PATIENTS) ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
; IHS/TUCSON/VJM - SELPT sub-rtn: change READ to a DIR call. Added
; the LIST sub-rtn which is called from SELPT
;
W !!,"* * * B A T C H H E A L T H S U M M A R Y P R O G R A M * * *",!!
S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",$I,"")) ; SET DEFAULT OUTPUT DEVICE
;
SELTYP K DIC S DIC=9001015,DIC("A")="Select health summary type: ",DIC(0)="AEQM"
S X="ADULT REGULAR"
I $D(^DISV(DUZ,"^APCHSCTL(")) S Y=^("^APCHSCTL(") I $D(^APCHSCTL(Y,0)) S X=$P(^(0),U,1)
S DIC("B")=X
D ^DIC I Y>0 S APCHSTYP=+Y,APCHSMI=0 K APCHSPAT D SELPT W ! G SELTYP
G END
;
SELPT ;
F D Q:U[X
.S DIR(0)="FOU",DIR("A")="Select patient(s)"
.S DIR("?",1)=" Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN).",DIR("?",2)=""
.S DIR("?",3)=" A template can also be selected by typing a ""["" followed by",DIR("?",4)=" the template name."
.S DIR("?",5)="",DIR("?")=" ""[??"" will list your templates.",DIR("??")="^D LIST^APCHSM"
.D ^DIR K DIR
.S:X[U X=U
.I $E(X)="[" D Q
.. S X=$E(X,2,$L(X))
..; K DIC S DIC=.401,DIC(0)=$S(X="":"AEMQ",1:"EMQ"),DIC("S")="I ($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")" D ^DIC
.. K DIC S DIC=.401,DIC(0)=$S(X="":"AEMQ",1:"EMQ"),DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001),($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")" D ^DIC
.. I Y>0 D
... S APCHSPAT=0,Y=+Y F APCHMJ=0:1 S APCHSPAT=$O(^DIBT(Y,1,APCHSPAT)) Q:'APCHSPAT S APCHSMI=APCHSMI+1,APCHSPAT(APCHSMI)=APCHSPAT
... W !,APCHMJ,$S(APCHMJ=1:" entry",1:" entries")," added."
.K DIC S DIC=9000001,DIC(0)="EQM" D ^DIC
.I Y>0 S APCHSPAT=+Y,APCHSMI=APCHSMI+1,APCHSPAT(APCHSMI)=APCHSPAT
W !
I X=U K APCHSPAT W !,$C(7),"All selections cancelled!"
Q:'$O(APCHSPAT(""))
D SELDEV I APCHSMF="POP" S IO=IO(0) Q
I APCHSMF="QUE" D QUE D ^%ZISC Q
K ZTSK
;
SUMLOOP ;ENTRY POINT
S APCHSMI=0 F APCHSMQ=0:0 S APCHSMI=$O(APCHSPAT(APCHSMI)) Q:'APCHSMI S APCHSPAT=APCHSPAT(APCHSMI) D EN^APCHS
D ^%ZISC
;
END K APCHSPAT,APCHSTYP,APCHSM,APCHSMQ,APCHSMI,APCHSMF,APCHSMK,APCHMJ
K APCHSALL,APCHSTAT,G,X,Y
D EOJ^APCHS
K AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX,AUPNDAYS
K DIC
Q
;
SELDEV ; SELECT OUTPUT DEVICE
K IOP,%ZIS S %ZIS="PQ" D ^%ZIS S APCHSMF=$S(POP:"POP",$D(IO("Q")):"QUE",1:"")
I APCHSMF="" S ^DISV($I,"^%ZIS(1,")=$O(^%ZIS(1,"C",IO,""))
Q
;
QUE ;
K ZTSAVE F G="APCHSPAT(","APCHSTYP" S ZTSAVE(G)=""
S ZTRTN="SUMLOOP^APCHSM",ZTDESC="BATCH HEALTH SUMMARY",ZTIO=ION,ZTDTH="" ;IHS/CMI/LAB - ION
D ^%ZTLOAD
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
;
LIST ;"??" help list
S APCHMK=0,APCHMJ=IOSL-3 F S APCHMK=$O(APCHSPAT(APCHMK)) Q:'APCHMK S APCHSPAT=APCHSPAT(APCHMK),X=$P(^AUPNPAT(APCHSPAT,0),U) D Q:APCHMJ<0 W !,?2,X
. S APCHMJ=APCHMJ-1 Q:APCHMJ>0 S APCHMJ=IOSL-2
. K DIR S DIR(0)="E" D ^DIR I 'Y K DIRUT,DUOUT,DTOUT S APCHMJ=-1
. S X=" " K DIR Q
K APCHMK
Q
APCHSM ; IHS/CMI/LAB - HEALTH SUMMARY (MULTIPLE PATIENTS) ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ; IHS/TUCSON/VJM - SELPT sub-rtn: change READ to a DIR call. Added
+3 ; the LIST sub-rtn which is called from SELPT
+4 ;
+5 WRITE !!,"* * * B A T C H H E A L T H S U M M A R Y P R O G R A M * * *",!!
+6 ; SET DEFAULT OUTPUT DEVICE
SET ^DISV($IO,"^%ZIS(1,")=$ORDER(^%ZIS(1,"C",$IO,""))
+7 ;
SELTYP KILL DIC
SET DIC=9001015
SET DIC("A")="Select health summary type: "
SET DIC(0)="AEQM"
+1 SET X="ADULT REGULAR"
+2 IF $DATA(^DISV(DUZ,"^APCHSCTL("))
SET Y=^("^APCHSCTL(")
IF $DATA(^APCHSCTL(Y,0))
SET X=$PIECE(^(0),U,1)
+3 SET DIC("B")=X
+4 DO ^DIC
IF Y>0
SET APCHSTYP=+Y
SET APCHSMI=0
KILL APCHSPAT
DO SELPT
WRITE !
GOTO SELTYP
+5 GOTO END
+6 ;
SELPT ;
+1 FOR
Begin DoDot:1
+2 SET DIR(0)="FOU"
SET DIR("A")="Select patient(s)"
+3 SET DIR("?",1)=" Enter a patient's HRN or name (HORSECHIEF,JOHN DOE or HORSECHIEF,JOHN)."
SET DIR("?",2)=""
+4 SET DIR("?",3)=" A template can also be selected by typing a ""["" followed by"
SET DIR("?",4)=" the template name."
+5 SET DIR("?",5)=""
SET DIR("?")=" ""[??"" will list your templates."
SET DIR("??")="^D LIST^APCHSM"
+6 DO ^DIR
KILL DIR
+7 IF X[U
SET X=U
+8 IF $EXTRACT(X)="["
Begin DoDot:2
+9 SET X=$EXTRACT(X,2,$LENGTH(X))
+10 ; K DIC S DIC=.401,DIC(0)=$S(X="":"AEMQ",1:"EMQ"),DIC("S")="I ($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")" D ^DIC
+11 KILL DIC
SET DIC=.401
SET DIC(0)=$SELECT(X="":"AEMQ",1:"EMQ")
SET DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001),($P(^(0),U,5)=$G(DUZ))!(DUZ(0)=""@"")"
DO ^DIC
+12 IF Y>0
Begin DoDot:3
+13 SET APCHSPAT=0
SET Y=+Y
FOR APCHMJ=0:1
SET APCHSPAT=$ORDER(^DIBT(Y,1,APCHSPAT))
IF 'APCHSPAT
QUIT
SET APCHSMI=APCHSMI+1
SET APCHSPAT(APCHSMI)=APCHSPAT
+14 WRITE !,APCHMJ,$SELECT(APCHMJ=1:" entry",1:" entries")," added."
End DoDot:3
End DoDot:2
QUIT
+15 KILL DIC
SET DIC=9000001
SET DIC(0)="EQM"
DO ^DIC
+16 IF Y>0
SET APCHSPAT=+Y
SET APCHSMI=APCHSMI+1
SET APCHSPAT(APCHSMI)=APCHSPAT
End DoDot:1
IF U[X
QUIT
+17 WRITE !
+18 IF X=U
KILL APCHSPAT
WRITE !,$CHAR(7),"All selections cancelled!"
+19 IF '$ORDER(APCHSPAT(""))
QUIT
+20 DO SELDEV
IF APCHSMF="POP"
SET IO=IO(0)
QUIT
+21 IF APCHSMF="QUE"
DO QUE
DO ^%ZISC
QUIT
+22 KILL ZTSK
+23 ;
SUMLOOP ;ENTRY POINT
+1 SET APCHSMI=0
FOR APCHSMQ=0:0
SET APCHSMI=$ORDER(APCHSPAT(APCHSMI))
IF 'APCHSMI
QUIT
SET APCHSPAT=APCHSPAT(APCHSMI)
DO EN^APCHS
+2 DO ^%ZISC
+3 ;
END KILL APCHSPAT,APCHSTYP,APCHSM,APCHSMQ,APCHSMI,APCHSMF,APCHSMK,APCHMJ
+1 KILL APCHSALL,APCHSTAT,G,X,Y
+2 DO EOJ^APCHS
+3 KILL AUPNPAT,AUPNDOB,AUPNDOD,AUPNSEX,AUPNDAYS
+4 KILL DIC
+5 QUIT
+6 ;
SELDEV ; SELECT OUTPUT DEVICE
+1 KILL IOP,%ZIS
SET %ZIS="PQ"
DO ^%ZIS
SET APCHSMF=$SELECT(POP:"POP",$DATA(IO("Q")):"QUE",1:"")
+2 IF APCHSMF=""
SET ^DISV($IO,"^%ZIS(1,")=$ORDER(^%ZIS(1,"C",IO,""))
+3 QUIT
+4 ;
QUE ;
+1 KILL ZTSAVE
FOR G="APCHSPAT(","APCHSTYP"
SET ZTSAVE(G)=""
+2 ;IHS/CMI/LAB - ION
SET ZTRTN="SUMLOOP^APCHSM"
SET ZTDESC="BATCH HEALTH SUMMARY"
SET ZTIO=ION
SET ZTDTH=""
+3 DO ^%ZTLOAD
+4 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+5 QUIT
+6 ;
LIST ;"??" help list
+1 SET APCHMK=0
SET APCHMJ=IOSL-3
FOR
SET APCHMK=$ORDER(APCHSPAT(APCHMK))
IF 'APCHMK
QUIT
SET APCHSPAT=APCHSPAT(APCHMK)
SET X=$PIECE(^AUPNPAT(APCHSPAT,0),U)
Begin DoDot:1
+2 SET APCHMJ=APCHMJ-1
IF APCHMJ>0
QUIT
SET APCHMJ=IOSL-2
+3 KILL DIR
SET DIR(0)="E"
DO ^DIR
IF 'Y
KILL DIRUT,DUOUT,DTOUT
SET APCHMJ=-1
+4 SET X=" "
KILL DIR
QUIT
End DoDot:1
IF APCHMJ<0
QUIT
WRITE !,?2,X
+5 KILL APCHMK
+6 QUIT
