PSGPOR ;BIR/CML3-PATIENT ORDER PURGE REPORT ;24 JAN 94 / 11:15 AM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
S PSGPOD=$E($$ENDTC^PSGMI(PSGPOD),1,8) D NOW^%DTC S PSGOD=$$ENDTC^PSGMI(%) S (LN1,LN2,PG)="",$P(LN1,"-",81)="",$P(LN2,"=",81)="" U IO D HEADER I '$O(^PS(53.43,1,1,PSGJ,1,0)) W !!!?31,"NO ORDERS PURGED." G DONE
S (PG,PT,NDT)=0 F PSGP=0:0 S PSGP=$O(^PS(53.43,1,1,PSGJ,1,PSGP)) Q:'PSGP S ND=$P(^(PSGP,0),"^",2) D:$Y+5>IOSL HEADER D WRT
D:$Y+9>IOSL HEADER W !!!,LN2,!!?3,"PATIENTS: ",PT,?55,$J(NDT,5,0) W:$Y @IOF
;
DONE ;
W:$Y @IOF K ^PS(53.43,1,1,PSGJ),ND,NDT,PT,PSGP,PSGID,PSGOD,LN1,LN2 Q
;
S PG=PG+1 W:$Y @IOF W !!?25,"PATIENT ORDER PURGE REPORT",?64,PSGOD,!?16,"(FOR PATIENTS DISCHARGED ON OR BEFORE ",PSGPOD,")",?73-$L(PG),"Page: ",PG,!?5,"Patient",?55,"Number of",!?55,"Orders Purged",!,LN1 Q
;
WRT ;
S PN=$G(^DPT(PSGP,0)) W !!?2,$S($P(PN,"^")]"":$P(PN,"^"),1:PSGP),$S($P(PN,"^",9):" ("_$E($P(PN,"^",9),6,10)_")",1:""),?55,$J(ND,5,0) S PT=PT+1,NDT=NDT+ND Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGPOR 1001 printed Sep 23, 2025@19:39:07 Page 2
PSGPOR ;BIR/CML3-PATIENT ORDER PURGE REPORT ;24 JAN 94 / 11:15 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
+2 SET PSGPOD=$EXTRACT($$ENDTC^PSGMI(PSGPOD),1,8)
DO NOW^%DTC
SET PSGOD=$$ENDTC^PSGMI(%)
SET (LN1,LN2,PG)=""
SET $PIECE(LN1,"-",81)=""
SET $PIECE(LN2,"=",81)=""
USE IO
DO HEADER
IF '$ORDER(^PS(53.43,1,1,PSGJ,1,0))
WRITE !!!?31,"NO ORDERS PURGED."
GOTO DONE
+3 SET (PG,PT,NDT)=0
FOR PSGP=0:0
SET PSGP=$ORDER(^PS(53.43,1,1,PSGJ,1,PSGP))
if 'PSGP
QUIT
SET ND=$PIECE(^(PSGP,0),"^",2)
if $Y+5>IOSL
DO HEADER
DO WRT
+4 if $Y+9>IOSL
DO HEADER
WRITE !!!,LN2,!!?3,"PATIENTS: ",PT,?55,$JUSTIFY(NDT,5,0)
if $Y
WRITE @IOF
+5 ;
DONE ;
+1 if $Y
WRITE @IOF
KILL ^PS(53.43,1,1,PSGJ),ND,NDT,PT,PSGP,PSGID,PSGOD,LN1,LN2
QUIT
+2 ;
+1 SET PG=PG+1
if $Y
WRITE @IOF
WRITE !!?25,"PATIENT ORDER PURGE REPORT",?64,PSGOD,!?16,"(FOR PATIENTS DISCHARGED ON OR BEFORE ",PSGPOD,")",?73-$LENGTH(PG),"Page: ",PG,!?5,"Patient",?55,"Number of",!?55,"Orders Purged",!,LN1
QUIT
+2 ;
WRT ;
+1 SET PN=$GET(^DPT(PSGP,0))
WRITE !!?2,$SELECT($PIECE(PN,"^")]"":$PIECE(PN,"^"),1:PSGP),$SELECT($PIECE(PN,"^",9):" ("_$EXTRACT($PIECE(PN,"^",9),6,10)_")",1:""),?55,$JUSTIFY(ND,5,0)
SET PT=PT+1
SET NDT=NDT+ND
QUIT
