ADGCRB0.m

ADGCRB0 ; IHS/ADC/PDW/ENM - A SHEET driver ; [ 03/25/1999  11:48 AM ]

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

 ;

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

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

MAIN ; -- main

 I '$D(DFN)!('$D(^DPT(DFN,0)))!('$D(^AUPNPAT(DFN,0))) Q

 S DGDS=0,DGFN=$S($G(DGFN):$G(DGFN),1:0)

 ;D ASK:DGFN,1:'DGFN I 'DGFN D Q Q

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

 D BOT I $D(DIRUT) D Q Q

 D NOC I $D(DIRUT) D Q Q

 D ZIS I POP D Q Q

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

 D A,Q Q

 ;

EN(DFN,DGFN) ;EP; -- predefined DFN entry point

 D MAIN Q

 ;

ASK ; -- print?

 S DIR(0)="Y",DIR("A")="Do you want to print A sheet",DIR("B")="YES"

 D ^DIR S:'Y DGFN=0 Q

 ;

A U IO F DGZCNT=1:1:DGZC D

 . D ^ADGCRB1

 . I $D(DGZP) D ^ADGCRB5 D:DGVSDA ^ADGCRB6   ;2nd half (clinical data)

 . D:$D(DGZN) ^ADGCRB7 W @IOF                ;2nd half (form outline)

 Q

 ;

1 ; --  admission

 N I,J,ID,Y,X

 I '$D(^DGPM("APCA",DFN)) D  Q

 . W !?5,"No admissions on file." D PRTOPT^ADGVAR

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

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

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

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

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

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

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

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

 S DGFN=J(+Y)

 Q

 ;

BOT ; -- bottom half form?

 Q:$D(DGZP)  K DIR,DGZN W !

 S DIR("A")="Print bottom half of form"

 S DIR("B")=$S($G(DGDS):"NO",1:"YES"),DIR("?")="",DIR(0)="Y"

 S DIR("?",1)="Enter YES if you wish to print the headings for"

 S DIR("?",2)="         the second half of the A Sheet form,"

 S DIR("?",3)="Enter NO to leave second half blank."

 D ^DIR S:Y DGZN="" Q

 ;

NOC ; -- number of copies

 K DIR S DIR(0)="N^1:10",DIR("B")=1 S DIR("A")="Print How Many Copies"

 D ^DIR S DGZC=Y Q

 ;

ZIS ; -- select device

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

 ;

QUE ; -- queued output

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

 F I="DFN","DGDS","DGFN","DGZC","DGZN","DGZP" S ZTSAVE(I)=""

 D ^%ZTLOAD Q

 ;

Q ; -- cleanup

 K DGFN,DGZC,ZTSK,X,Y,DIC,IO("Q"),DGZCNT,%ZIS,DGLIN,DGLIN1,DIR

 K DGVSDA,DGPOVN0,DGPOVDA,DGN,DGN0,DGN11,DGN21,DGN33,DGDS,DFN,DGZP

 D ^%ZISC,HOME^%ZIS Q

 ;

DS ;EP; -- day surgery

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

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

DS1 ;EP; -- ds main

 D DSSD I Y<1 D Q Q

 I $$DSV^ADGCRB5 S DGZP="" K DGZN

 D BOT I $D(DIRUT) D Q Q

 D NOC I $D(DIRUT) D Q Q

 D ZIS I POP D Q Q

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

 D A,Q Q

 ;

DSSD ; -- select day surgery date

 I '$D(^ADGDS(DFN,"DS")) D  S Y=0 Q

 . W !,"No Day Surgery for ",$P(^DPT(DFN,0),U),!

 S DIC="^ADGDS("_DFN_",""DS"",",DIC(0)="AEFMNQ"

 S DIC("B")=$S($D(^ADGDS(DFN,"DS",0)):$P(^(0),U,3),1:"")

 D ^DIC S DGDS=+Y

 Q

 ;

EN1 ;EP; -- A Sheet by Admission date

 W @IOF,!!!?24,"PRINT A SHEETS BY ADMISSION DATE",!! S DGDS=0

 D DT I X["^"!($D(DTOUT))!(X="") D Q Q

 D BOT I $D(DIRUT) D Q Q

 D NOC I $D(DIRUT) D Q Q

 D ZIS I POP D Q Q

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

EN2 D LP1,Q Q

 ;

QUE1 ; -- queued output

 S ZTRTN="EN2^ADGCRB0",ZTDESC="PRINT FORM 44-1"

 F I="DFN","DGDS","DGFN","DGZC","DGZN" S ZTSAVE(I)=""

 D ^%ZTLOAD Q

 ;

DT ; -- Admission date

 S %DT="AEQ",%DT("A")="Select admission date: " D ^%DT  Q:Y<0

 S SD=Y-.0001,ED=Y+.2400 Q

 ;

LP1 ; -- loop admission date

 S DGDT=SD F  S DGDT=$O(^DGPM("AMV1",DGDT)) Q:'DGDT!(DGDT>ED)  D

 . S DFN=0 F  S DFN=$O(^DGPM("AMV1",DGDT,DFN)) Q:'DFN  D

 .. S DGFN=0 F  S DGFN=$O(^DGPM("AMV1",DGDT,DFN,DGFN)) Q:'DGFN  D A

 Q

ADGCRB0   ; IHS/ADC/PDW/ENM - A SHEET driver ; [ 03/25/1999  11:48 AM ]

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

 +2       ;

 +3        SET DIC="^DPT("

           SET DIC(0)="AQZEM"

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

 +4        DO ^DIC

           KILL DIC

           IF Y'>0

               GOTO Q

           SET DFN=+Y

MAIN      ; -- main

 +1        IF '$DATA(DFN)!('$DATA(^DPT(DFN,0)))!('$DATA(^AUPNPAT(DFN,0)))

               QUIT 

 +2        SET DGDS=0

           SET DGFN=$SELECT($GET(DGFN):$GET(DGFN),1:0)

 +3       ;D ASK:DGFN,1:'DGFN I 'DGFN D Q Q

 +4        NEW X

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

           DO @X

           IF 'DGFN

               DO Q

               QUIT 

 +5        DO BOT

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +6        DO NOC

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +7        DO ZIS

           IF POP

               DO Q

               QUIT 

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

               DO QUE

               DO Q

               QUIT 

 +9        DO A

           DO Q

           QUIT 

 +10      ;

EN(DFN,DGFN) ;EP; -- predefined DFN entry point

 +1        DO MAIN

           QUIT 

 +2       ;

ASK       ; -- print?

 +1        SET DIR(0)="Y"

           SET DIR("A")="Do you want to print A sheet"

           SET DIR("B")="YES"

 +2        DO ^DIR

           IF 'Y

               SET DGFN=0

           QUIT 

 +3       ;

A          USE IO

           FOR DGZCNT=1:1:DGZC

               Begin DoDot:1

 +1                DO ^ADGCRB1

 +2       ;2nd half (clinical data)

                   IF $DATA(DGZP)

                       DO ^ADGCRB5

                       IF DGVSDA

                           DO ^ADGCRB6

 +3       ;2nd half (form outline)

                   IF $DATA(DGZN)

                       DO ^ADGCRB7

                   WRITE @IOF

               End DoDot:1

 +4        QUIT 

 +5       ;

1         ; --  admission

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

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

               Begin DoDot:1

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

                   DO PRTOPT^ADGVAR

               End DoDot:1

               QUIT 

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

           SET I=0

 +5        SET ID=0

           FOR 

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

               IF 'ID

                   QUIT 

               Begin DoDot:1

 +6                SET DGFN=0

                   FOR 

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

                       IF 'DGFN

                           QUIT 

                       Begin DoDot:2

 +7                        SET Y=+^DGPM(DGFN,0)

                           SET I=I+1

                           SET J(I)=DGFN

                           XECUTE ^DD("DD")

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

                       End DoDot:2

               End DoDot:1

 +8        IF I=1

               SET DGFN=J(I)

               QUIT 

 +9        KILL DIR

           SET DIR("B")=1

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

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

           DO ^DIR

           KILL DIR

 +10       IF Y=""

               SET DGFN=J(1)

               QUIT 

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

               SET DGFN=0

               QUIT 

 +12       SET DGFN=J(+Y)

 +13       QUIT 

 +14      ;

BOT       ; -- bottom half form?

 +1        IF $DATA(DGZP)

               QUIT 

           KILL DIR,DGZN

           WRITE !

 +2        SET DIR("A")="Print bottom half of form"

 +3        SET DIR("B")=$SELECT($GET(DGDS):"NO",1:"YES")

           SET DIR("?")=""

           SET DIR(0)="Y"

 +4        SET DIR("?",1)="Enter YES if you wish to print the headings for"

 +5        SET DIR("?",2)="         the second half of the A Sheet form,"

 +6        SET DIR("?",3)="Enter NO to leave second half blank."

 +7        DO ^DIR

           IF Y

               SET DGZN=""

           QUIT 

 +8       ;

NOC       ; -- number of copies

 +1        KILL DIR

           SET DIR(0)="N^1:10"

           SET DIR("B")=1

           SET DIR("A")="Print How Many Copies"

 +2        DO ^DIR

           SET DGZC=Y

           QUIT 

 +3       ;

ZIS       ; -- select device

 +1        SET %ZIS="PQ"

           DO ^%ZIS

           QUIT 

 +2       ;

QUE       ; -- queued output

 +1        SET ZTRTN="A^ADGCRB0"

           SET ZTDESC="PRINT FORM 44-1"

 +2        FOR I="DFN","DGDS","DGFN","DGZC","DGZN","DGZP"

               SET ZTSAVE(I)=""

 +3        DO ^%ZTLOAD

           QUIT 

 +4       ;

Q         ; -- cleanup

 +1        KILL DGFN,DGZC,ZTSK,X,Y,DIC,IO("Q"),DGZCNT,%ZIS,DGLIN,DGLIN1,DIR

 +2        KILL DGVSDA,DGPOVN0,DGPOVDA,DGN,DGN0,DGN11,DGN21,DGN33,DGDS,DFN,DGZP

 +3        DO ^%ZISC

           DO HOME^%ZIS

           QUIT 

 +4       ;

DS        ;EP; -- day surgery

 +1        SET DIC="^DPT("

           SET DIC(0)="AQZEM"

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

 +2        DO ^DIC

           KILL DIC

           IF Y'>0

               GOTO Q

           SET DFN=+Y

DS1       ;EP; -- ds main

 +1        DO DSSD

           IF Y<1

               DO Q

               QUIT 

 +2        IF $$DSV^ADGCRB5

               SET DGZP=""

               KILL DGZN

 +3        DO BOT

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +4        DO NOC

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +5        DO ZIS

           IF POP

               DO Q

               QUIT 

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

               DO QUE

               DO Q

               QUIT 

 +7        DO A

           DO Q

           QUIT 

 +8       ;

DSSD      ; -- select day surgery date

 +1        IF '$DATA(^ADGDS(DFN,"DS"))

               Begin DoDot:1

 +2                WRITE !,"No Day Surgery for ",$PIECE(^DPT(DFN,0),U),!

               End DoDot:1

               SET Y=0

               QUIT 

 +3        SET DIC="^ADGDS("_DFN_",""DS"","

           SET DIC(0)="AEFMNQ"

 +4        SET DIC("B")=$SELECT($DATA(^ADGDS(DFN,"DS",0)):$PIECE(^(0),U,3),1:"")

 +5        DO ^DIC

           SET DGDS=+Y

 +6        QUIT 

 +7       ;

EN1       ;EP; -- A Sheet by Admission date

 +1        WRITE @IOF,!!!?24,"PRINT A SHEETS BY ADMISSION DATE",!!

           SET DGDS=0

 +2        DO DT

           IF X["^"!($DATA(DTOUT))!(X="")

               DO Q

               QUIT 

 +3        DO BOT

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +4        DO NOC

           IF $DATA(DIRUT)

               DO Q

               QUIT 

 +5        DO ZIS

           IF POP

               DO Q

               QUIT 

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

               DO QUE1

               DO Q

               QUIT 

EN2        DO LP1

           DO Q

           QUIT 

 +1       ;

QUE1      ; -- queued output

 +1        SET ZTRTN="EN2^ADGCRB0"

           SET ZTDESC="PRINT FORM 44-1"

 +2        FOR I="DFN","DGDS","DGFN","DGZC","DGZN"

               SET ZTSAVE(I)=""

 +3        DO ^%ZTLOAD

           QUIT 

 +4       ;

DT        ; -- Admission date

 +1        SET %DT="AEQ"

           SET %DT("A")="Select admission date: "

           DO ^%DT

           IF Y<0

               QUIT 

 +2        SET SD=Y-.0001

           SET ED=Y+.2400

           QUIT 

 +3       ;

LP1       ; -- loop admission date

 +1        SET DGDT=SD

           FOR 

               SET DGDT=$ORDER(^DGPM("AMV1",DGDT))

               IF 'DGDT!(DGDT>ED)

                   QUIT 

               Begin DoDot:1

 +2                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DGPM("AMV1",DGDT,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +3                        SET DGFN=0

                           FOR 

                               SET DGFN=$ORDER(^DGPM("AMV1",DGDT,DFN,DGFN))

                               IF 'DGFN

                                   QUIT 

                               DO A

                       End DoDot:2

               End DoDot:1

 +4        QUIT