- ACRFQ ;IHS/OIRM/DSD/THL,AEF - ROUTINE TO PRINT SELECTED DOCUMENTS; [ 11/01/2001 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- ;;ROUTINE TO PRINT SELECTED DOCUMENTS
- EN S:'$D(ACRCOPY) ACRCOPY=1
- S:ACRCOPY<1 ACRCOPY=1
- S:$E(IOST,1,2)="C-" ACRCOPY=1
- S:ACRCOPY>6 ACRCOPY=6
- F ACRIII=1:1:ACRCOPY D EN1
- EXIT K ACRII,ACRCOPY,ACRCOST
- I $D(ZTSK)#2,ZTSK,$D(^%ZTSK(ZTSK)) D STAT^%ZTLOAD I $D(ZTSK(1)),ZTSK(1)=3 D KILL^%ZTLOAD
- Q
- EN1 K ACRQUIT,ACROUT
- W " "
- S (ACRDOCDA,D0)=ACRDOCDA
- D SETDOC^ACRFEA1
- N DXS,DIP,DC,DN
- S:'$D(ACRREFX) ACRREFX=ACRREF
- I $P($G(^ACRDOC(ACRDOCDA,0)),U,4)=35 N ACRREF,ACRREFX,ACRREQST S (ACRREF,ACRREFX)=116,ACRREQST=""
- I '$D(ACRRR)#2,$D(^ACRDOC(ACRDOCDA,3)),$P(^(3),U,13) N ACRREFX,ACRPO S ACRREFX=210
- I ACRREFX=116&$D(ACRREQST)&$D(ACRPSUM) D ^ACRPRQS Q
- I ACRREFX=116&$D(ACRREQST) D ^ACRPRQT D EN2 D Q
- .S:'$D(D0) D0=ACRDOCDA
- .I '$D(ACROUT),$D(ACREQUIP) S D0=ACRDOCDA D ^ACRPEC N ACREQUIP,DXS,DIP,DC,DN W:$Y>1 @IOF Q
- .I '$D(ACROUT),$P(^ACRDOC(ACRDOCDA,0),U,18)>0 S D0=ACRDOCDA N DXS,DIP,DC,DN D ^ACRPBPA W:$Y>1 @IOF Q
- I ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!$D(ACRPO) D D EN2 Q
- .I '$P(^ACRDOC(ACRDOCDA,0),U,15) D
- ..I ACRREFX=326,'$D(ACRPSC) S ACRPSC=326
- ..I '$D(ACRPSC) D ^ACRPSS Q
- ..S ACRPX="^ACRF"_$P(ACRPSC,U)
- ..I +ACRPSC=326 S ACRPX="^ACRNP1"
- ..D @ACRPX
- .D ^ACRPPOA:$P(^ACRDOC(ACRDOCDA,0),U,15)
- .W:$Y>1 @IOF
- .I $E(IOST,1,2)="P-",'$P(^ACRDOC(ACRDOCDA,0),U,15),$P(^ACRSYS(1,"DT"),U,23) S D0=1 D ^ACRPTC W @IOF
- .I '$D(ACROUT),$P(^ACRDOC(ACRDOCDA,0),U,18)>0 S D0=ACRDOCDA N DXS,DIP,DC,DN D ^ACRPBPA W:$Y>1 @IOF Q
- I ACRREFX=130!(ACRREFX=600),ACRREF=130!(ACRREF=600) D ^ACRFTOT
- I ACRREFX=130&$D(ACRREQST)&$D(ACRPSUM) D ^ACRPTOS Q
- I ACRREFX=130&$D(ACRTVI)&$D(ACRREQST) D ^ACRPSTI D EN2 Q
- I ACRREFX=130&$D(ACRREQST) D ^ACRPTO D EN2 Q
- I ACRREFX=499 D ^ACRRR D EN2 Q
- I ACRREFX=210 D Q
- .I '$P($G(^ACRDOC(ACRDOCDA,3)),U,17) D ^ACRFFS I 1
- .E D ^ACRF3542
- .D EN2
- I ACRREFX=148 D ^ACRPTRG D EN2 Q
- I ACRREFX=600&$D(ACRPSUM) D ^ACRPTVS Q
- I ACRREFX=600 D ^ACRPTV D EN2 Q
- I ACRREFX=999 D ^ACRFPRS D EN2 Q
- I '$D(ACRREV) D ^ACRFPCRT D EN2 Q
- Q
- EN2 N DXS,DIP,DC,DN
- I '$D(ACROUT),ACRREFX=116,$D(^ACROBL(ACRDOCDA,1,1,0)) S D0=ACRDOCDA N DXS,DIP,DC,DN D ^ACRPAR D PAUSE^ACRFWARN W:$Y>1 @IOF
- I '$D(ACROUT),ACRREFX=148,$D(ACRTVAL) W @IOF S D0=ACRDOCDA N DXS,DIP,DC,DN W @IOF D ^ACRPTE D PAUSE^ACRFWARN W:$Y>1 @IOF K ACRTVAL
- I $D(ACRCOST),'$D(ACROUT),"^103^349^326^116^204^210^"[(U_ACRREFX_U) D EN^ACRFPCC
- I $D(ACRDHR) W:$Y>1 @IOF D PRINT^ACRFDHR
- I $D(ACRSHIP),$D(^ACRSI("B",ACRDOCDA)) D DISPLAY^ACRFSHIP K ACRSHIP
- W:$Y>1 @IOF
- K DC,ACRPOTC,ACRDHR
- Q
- REQ ;EP;TO SETUP TO PRINT REQUEST
- S ACRRTN="^ACRFQ",ZTDESC="PRINT ARMS REQUEST"_$S($D(ACRDOC):", DOCUMENT # "_ACRDOC,1:"")
- D ^ACRFZIS
- Q
- ACRFQ ;IHS/OIRM/DSD/THL,AEF - ROUTINE TO PRINT SELECTED DOCUMENTS; [ 11/01/2001 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
- +2 ;;ROUTINE TO PRINT SELECTED DOCUMENTS
- EN IF '$DATA(ACRCOPY)
- SET ACRCOPY=1
- +1 IF ACRCOPY<1
- SET ACRCOPY=1
- +2 IF $EXTRACT(IOST,1,2)="C-"
- SET ACRCOPY=1
- +3 IF ACRCOPY>6
- SET ACRCOPY=6
- +4 FOR ACRIII=1:1:ACRCOPY
- DO EN1
- EXIT KILL ACRII,ACRCOPY,ACRCOST
- +1 IF $DATA(ZTSK)#2
- IF ZTSK
- IF $DATA(^%ZTSK(ZTSK))
- DO STAT^%ZTLOAD
- IF $DATA(ZTSK(1))
- IF ZTSK(1)=3
- DO KILL^%ZTLOAD
- +2 QUIT
- EN1 KILL ACRQUIT,ACROUT
- +1 WRITE " "
- +2 SET (ACRDOCDA,D0)=ACRDOCDA
- +3 DO SETDOC^ACRFEA1
- +4 NEW DXS,DIP,DC,DN
- +5 IF '$DATA(ACRREFX)
- SET ACRREFX=ACRREF
- +6 IF $PIECE($GET(^ACRDOC(ACRDOCDA,0)),U,4)=35
- NEW ACRREF,ACRREFX,ACRREQST
- SET (ACRREF,ACRREFX)=116
- SET ACRREQST=""
- +7 IF '$DATA(ACRRR)#2
- IF $DATA(^ACRDOC(ACRDOCDA,3))
- IF $PIECE(^(3),U,13)
- NEW ACRREFX,ACRPO
- SET ACRREFX=210
- +8 IF ACRREFX=116&$DATA(ACRREQST)&$DATA(ACRPSUM)
- DO ^ACRPRQS
- QUIT
- +9 IF ACRREFX=116&$DATA(ACRREQST)
- DO ^ACRPRQT
- DO EN2
- Begin DoDot:1
- +10 IF '$DATA(D0)
- SET D0=ACRDOCDA
- +11 IF '$DATA(ACROUT)
- IF $DATA(ACREQUIP)
- SET D0=ACRDOCDA
- DO ^ACRPEC
- NEW ACREQUIP,DXS,DIP,DC,DN
- IF $Y>1
- WRITE @IOF
- QUIT
- +12 IF '$DATA(ACROUT)
- IF $PIECE(^ACRDOC(ACRDOCDA,0),U,18)>0
- SET D0=ACRDOCDA
- NEW DXS,DIP,DC,DN
- DO ^ACRPBPA
- IF $Y>1
- WRITE @IOF
- QUIT
- End DoDot:1
- QUIT
- +13 IF ACRREFX=103!(ACRREFX=349)!(ACRREFX=326)!$DATA(ACRPO)
- Begin DoDot:1
- +14 IF '$PIECE(^ACRDOC(ACRDOCDA,0),U,15)
- Begin DoDot:2
- +15 IF ACRREFX=326
- IF '$DATA(ACRPSC)
- SET ACRPSC=326
- +16 IF '$DATA(ACRPSC)
- DO ^ACRPSS
- QUIT
- +17 SET ACRPX="^ACRF"_$PIECE(ACRPSC,U)
- +18 IF +ACRPSC=326
- SET ACRPX="^ACRNP1"
- +19 DO @ACRPX
- End DoDot:2
- +20 IF $PIECE(^ACRDOC(ACRDOCDA,0),U,15)
- DO ^ACRPPOA
- +21 IF $Y>1
- WRITE @IOF
- +22 IF $EXTRACT(IOST,1,2)="P-"
- IF '$PIECE(^ACRDOC(ACRDOCDA,0),U,15)
- IF $PIECE(^ACRSYS(1,"DT"),U,23)
- SET D0=1
- DO ^ACRPTC
- WRITE @IOF
- +23 IF '$DATA(ACROUT)
- IF $PIECE(^ACRDOC(ACRDOCDA,0),U,18)>0
- SET D0=ACRDOCDA
- NEW DXS,DIP,DC,DN
- DO ^ACRPBPA
- IF $Y>1
- WRITE @IOF
- QUIT
- End DoDot:1
- DO EN2
- QUIT
- +24 IF ACRREFX=130!(ACRREFX=600)
- IF ACRREF=130!(ACRREF=600)
- DO ^ACRFTOT
- +25 IF ACRREFX=130&$DATA(ACRREQST)&$DATA(ACRPSUM)
- DO ^ACRPTOS
- QUIT
- +26 IF ACRREFX=130&$DATA(ACRTVI)&$DATA(ACRREQST)
- DO ^ACRPSTI
- DO EN2
- QUIT
- +27 IF ACRREFX=130&$DATA(ACRREQST)
- DO ^ACRPTO
- DO EN2
- QUIT
- +28 IF ACRREFX=499
- DO ^ACRRR
- DO EN2
- QUIT
- +29 IF ACRREFX=210
- Begin DoDot:1
- +30 IF '$PIECE($GET(^ACRDOC(ACRDOCDA,3)),U,17)
- DO ^ACRFFS
- IF 1
- +31 IF '$TEST
- DO ^ACRF3542
- +32 DO EN2
- End DoDot:1
- QUIT
- +33 IF ACRREFX=148
- DO ^ACRPTRG
- DO EN2
- QUIT
- +34 IF ACRREFX=600&$DATA(ACRPSUM)
- DO ^ACRPTVS
- QUIT
- +35 IF ACRREFX=600
- DO ^ACRPTV
- DO EN2
- QUIT
- +36 IF ACRREFX=999
- DO ^ACRFPRS
- DO EN2
- QUIT
- +37 IF '$DATA(ACRREV)
- DO ^ACRFPCRT
- DO EN2
- QUIT
- +38 QUIT
- EN2 NEW DXS,DIP,DC,DN
- +1 IF '$DATA(ACROUT)
- IF ACRREFX=116
- IF $DATA(^ACROBL(ACRDOCDA,1,1,0))
- SET D0=ACRDOCDA
- NEW DXS,DIP,DC,DN
- DO ^ACRPAR
- DO PAUSE^ACRFWARN
- IF $Y>1
- WRITE @IOF
- +2 IF '$DATA(ACROUT)
- IF ACRREFX=148
- IF $DATA(ACRTVAL)
- WRITE @IOF
- SET D0=ACRDOCDA
- NEW DXS,DIP,DC,DN
- WRITE @IOF
- DO ^ACRPTE
- DO PAUSE^ACRFWARN
- IF $Y>1
- WRITE @IOF
- KILL ACRTVAL
- +3 IF $DATA(ACRCOST)
- IF '$DATA(ACROUT)
- IF "^103^349^326^116^204^210^"[(U_ACRREFX_U)
- DO EN^ACRFPCC
- +4 IF $DATA(ACRDHR)
- IF $Y>1
- WRITE @IOF
- DO PRINT^ACRFDHR
- +5 IF $DATA(ACRSHIP)
- IF $DATA(^ACRSI("B",ACRDOCDA))
- DO DISPLAY^ACRFSHIP
- KILL ACRSHIP
- +6 IF $Y>1
- WRITE @IOF
- +7 KILL DC,ACRPOTC,ACRDHR
- +8 QUIT
- REQ ;EP;TO SETUP TO PRINT REQUEST
- +1 SET ACRRTN="^ACRFQ"
- SET ZTDESC="PRINT ARMS REQUEST"_$SELECT($DATA(ACRDOC):", DOCUMENT # "_ACRDOC,1:"")
- +2 DO ^ACRFZIS
- +3 QUIT
