PSGPOR.m

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

 ;

HEADER ;

 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 ---PSGPOR   1001     printed  Apr 09, 2024@21:10:14                                                                                                                                                                                                      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       ;

HEADER    ;

 +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