APCHSM.m

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