- 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
