ADGLOC0.m

ADGLOC0 ; IHS/ADC/PDW/ENM - LOCATOR CARD ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;

 N DFN,IFN,Y

 S DIC="^DPT(",DIC(0)="AQZEM",DIC("A")="Select PATIENT NAME: "

 D ^DIC K DIC G:Y'>0 Q S DFN=+Y

A ;EP; -- main

 S IFN=$S($G(IFN):IFN,1:0)

 N X S X=$S(IFN:"ASK",1:1) D @X I 'IFN D Q Q

 D DEV I POP D Q Q

 I $D(IO("Q")) D QUE,Q Q

 D ^ADGLOC1,Q Q

 ;

EN(DFN,IFN)        ;EP

 D A Q

 ;

ASK ; -- print?

 S DIR(0)="Y",DIR("A")="Print Locator Card",DIR("B")="YES"

 D ^DIR S:'Y IFN=0 Q

 ;

1 ; --  admission

 N ID,Y,I,J,X

 I '$D(^DGPM("APCA",DFN)) W !?5,"No admissions on file." S IFN=0 Q

 W !!,"Admission(s)" S I=0

 S ID=0 F  S ID=$O(^DGPM("ATID1",DFN,ID)) Q:'ID  D

 . S IFN=0 F  S IFN=$O(^DGPM("ATID1",DFN,ID,IFN)) Q:'IFN  D

 .. S Y=+^DGPM(IFN,0),I=I+1,J(I)=IFN X ^DD("DD") W !?5,I,".  ",Y

 I I=1 S IFN=J(I) Q

 K DIR S DIR("B")=1,DIR("A")="Select One",DIR(0)="NO^1:"_I D ^DIR

 I Y="" S IFN=J(1) Q

 I $D(DIRUT)!(Y=-1) S IFN=0 Q

 S IFN=J(X) Q

 ;

DEV ; -- select device

 W ! S %ZIS="PQ" D ^%ZIS Q

 ;

QUE ; -- queued output

 S ZTRTN="^ADGLOC1",ZTDESC="PRINT FORM 44-1A"

 N I F I="DFN","IFN" S ZTSAVE(I)=""

 D ^%ZTLOAD,^%ZISC K ZTSK,IO("Q") Q

 ;

Q ; -- cleanup

 D ^%ZISC Q

ADGLOC0   ; IHS/ADC/PDW/ENM - LOCATOR CARD ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3        NEW DFN,IFN,Y

 +4        SET DIC="^DPT("

           SET DIC(0)="AQZEM"

           SET DIC("A")="Select PATIENT NAME: "

 +5        DO ^DIC

           KILL DIC

           IF Y'>0

               GOTO Q

           SET DFN=+Y

A         ;EP; -- main

 +1        SET IFN=$SELECT($GET(IFN):IFN,1:0)

 +2        NEW X

           SET X=$SELECT(IFN:"ASK",1:1)

           DO @X

           IF 'IFN

               DO Q

               QUIT 

 +3        DO DEV

           IF POP

               DO Q

               QUIT 

 +4        IF $DATA(IO("Q"))

               DO QUE

               DO Q

               QUIT 

 +5        DO ^ADGLOC1

           DO Q

           QUIT 

 +6       ;

EN(DFN,IFN) ;EP

 +1        DO A

           QUIT 

 +2       ;

ASK       ; -- print?

 +1        SET DIR(0)="Y"

           SET DIR("A")="Print Locator Card"

           SET DIR("B")="YES"

 +2        DO ^DIR

           IF 'Y

               SET IFN=0

           QUIT 

 +3       ;

1         ; --  admission

 +1        NEW ID,Y,I,J,X

 +2        IF '$DATA(^DGPM("APCA",DFN))

               WRITE !?5,"No admissions on file."

               SET IFN=0

               QUIT 

 +3        WRITE !!,"Admission(s)"

           SET I=0

 +4        SET ID=0

           FOR 

               SET ID=$ORDER(^DGPM("ATID1",DFN,ID))

               IF 'ID

                   QUIT 

               Begin DoDot:1

 +5                SET IFN=0

                   FOR 

                       SET IFN=$ORDER(^DGPM("ATID1",DFN,ID,IFN))

                       IF 'IFN

                           QUIT 

                       Begin DoDot:2

 +6                        SET Y=+^DGPM(IFN,0)

                           SET I=I+1

                           SET J(I)=IFN

                           XECUTE ^DD("DD")

                           WRITE !?5,I,".  ",Y

                       End DoDot:2

               End DoDot:1

 +7        IF I=1

               SET IFN=J(I)

               QUIT 

 +8        KILL DIR

           SET DIR("B")=1

           SET DIR("A")="Select One"

           SET DIR(0)="NO^1:"_I

           DO ^DIR

 +9        IF Y=""

               SET IFN=J(1)

               QUIT 

 +10       IF $DATA(DIRUT)!(Y=-1)

               SET IFN=0

               QUIT 

 +11       SET IFN=J(X)

           QUIT 

 +12      ;

DEV       ; -- select device

 +1        WRITE !

           SET %ZIS="PQ"

           DO ^%ZIS

           QUIT 

 +2       ;

QUE       ; -- queued output

 +1        SET ZTRTN="^ADGLOC1"

           SET ZTDESC="PRINT FORM 44-1A"

 +2        NEW I

           FOR I="DFN","IFN"

               SET ZTSAVE(I)=""

 +3        DO ^%ZTLOAD

           DO ^%ZISC

           KILL ZTSK,IO("Q")

           QUIT 

 +4       ;

Q         ; -- cleanup

 +1        DO ^%ZISC

           QUIT