- PSJVOSR ;BIR/DRF-PRINT ACTIVE ORDER SCHEDULE VALIDATION ;13 APR 09 / 5:26 PM
- ;;5.0; INPATIENT MEDICATIONS ;**113**;16 DEC 97;Build 63
- ;
- ; Reference to ^PS(55 is supported by DBIA 2191.
- ; Reference to ^%ZTLOAD is supported by DBIA 10063.
- ; Reference to ^%DTC is supported by DBIA 10000.
- ; Reference to ^%ZIS is supported by DBIA 10086.
- ; Reference to ^%ZISC is supported by DBIA 10089.
- ; Reference to ^DIR is supported by DBIA 10026.
- ;
- SELDEV ;Ask for device type for report to output to
- K IOP,%ZIS,POP,IO("Q")
- W ! S %ZIS("A")="Select output device: ",%ZIS("B")="",%ZIS="Q"
- D ^%ZIS I POP W !,"** No device selected **" G EXIT
- W:'$D(IO("Q")) !,"this may take a while...(you should QUEUE this report)",!
- I $D(IO("Q")) D G EXIT
- . S XDESC="Problem Schedules on Orders"
- . S ZTRTN="START^PSJVOSR"
- . K IO("Q"),ZTSAVE,ZTDTH,ZTSK
- . S ZTDESC=XDESC,PSGIO=ION,ZTIO=PSGIO,ZTDTH=$H,ZTSAVE("PSJSORT")="",%ZIS="QN",IOP=PSGIO
- . D ^%ZIS,^%ZTLOAD
- ;
- START ;Loop through open orders.
- D NOW^%DTC S UL132="",$P(UL132,"-",132)="",PSJDATE=$$ENDTC^PSGMI(%),PSJPTR=$E(IOST)'="C",PG=0,PSIVAC="PH",PSJPAG=0
- U IO
- D HEAD
- S PSJTYP="U"
- S STPDT=$P(%,".")-1 F S STPDT=$O(^PS(55,"AUD",STPDT)) Q:STPDT="" D
- . S D0="" F S D0=$O(^PS(55,"AUD",STPDT,D0)) Q:D0="" D
- .. S D1="" F S D1=$O(^PS(55,"AUD",STPDT,D0,D1)) Q:D1="" D
- ... D TEST
- S PSJTYP="V"
- S STPDT=$P(%,".")-1 F S STPDT=$O(^PS(55,"AIV",STPDT)) Q:STPDT="" D
- . S D0="" F S D0=$O(^PS(55,"AIV",STPDT,D0)) Q:D0="" D
- .. S D1="" F S D1=$O(^PS(55,"AIV",STPDT,D0,D1)) Q:D1="" D
- ... D TEST
- EXIT ;Kill and exit.
- K %,%H,%I,%ZIS,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN
- K D0,D1,DONE,ERR,NAME,PG,PSGAT,PSGIO,PSGS0XT,PSGSCH,PSGSSP,PSGSST,PSGST
- K PSIVAC,PSJDATE,PSJPAG,PSJPTR,PSJTYP,SPD,SSN,STD,STPDT,UL132,X,XDESC,Y
- K ZTQUEUED,ZTREQ
- W:$E(IOST)="C"&($Y) @IOF
- S:$D(ZTQUEUED) ZTREQ="@"
- S IOP="HOME" D ^%ZISC
- Q
- ;
- DISPLAY ;Display Name, last 4 of SS, order number, start date, stop date, schedule, schedule type, admin times, error.
- S NAME=$$GET1^DIQ(2,D0,.01,"O")
- S SSN="XXX-XX-"_$E($$GET1^DIQ(2,D0,.09,"O"),6,9)
- S Y=PSGSST D DD^%DT S STD=Y
- S Y=PSGSSP D DD^%DT S SPD=Y
- D:($Y+5)>IOSL HEAD
- W !,NAME,?20,SSN,?33,STD,?52,SPD,?71,PSGSCH,?91,$S(+PSGS0XT:"C",1:PSGS0XT),?96,PSGAT,!,ERR
- Q
- ;
- PAUSE ;Hold screen.
- K DIR S DIR(0)="E" D ^DIR S:$D(DTOUT)!($D(DUOUT)) DONE=1
- Q
- ;
- TEST ;Check for errors.
- N D12,MAX
- I PSJTYP="U" D
- . S D12=$G(^PS(55,D0,5,D1,2))
- . S PSGSCH=$P(D12,"^",1),(X,PSGAT)=$P(D12,"^",5),PSGS0XT=$P(D12,"^",6),PSGSST=$P(D12,"^",2),PSGSSP=$P(D12,"^",4)
- I PSJTYP="V" D
- . S D12=$G(^PS(55,D0,"IV",D1,0))
- . S PSGSCH=$P(D12,"^",9),(X,PSGAT)=$P(D12,"^",11),PSGS0XT=$P(D12,"^",15),PSGSST=$P(D12,"^",2),PSGSSP=$P(D12,"^",3)
- I PSGSCH[" PRN" S PSGS0XT="P"
- I PSGS0XT="P" D Q ;No times required or allowed for PRN
- . I X="" Q
- . S ERR="Admin times not permitted for PRN schedule"
- . D DISPLAY
- I PSGS0XT="D"!(PSGS0XT)="OC" Q
- S PSGST=$S(PSGS0XT?1.N:"C",1:PSGS0XT)
- S ERR="" D
- . I X="" S ERR="This order requires at least one administration time" Q
- . I $G(PSGS0XT)="O",$L(X,"-")>1 S ERR="This is a One Time Order - only one admin time is permitted." Q
- . I +PSGS0XT=0 Q ;No frequency - can not check frequency related items
- . S MAX=1440/PSGS0XT
- . I MAX<1 D Q
- .. I $L(X,"-")'=1 S ERR="This order requires one admin time." Q
- . I MAX'<1,$L(X,"-")>MAX S ERR="The number of admin times entered is greater than indicated by the schedule." Q ;Too many times
- . I MAX'<1,$L(X,"-")<MAX S ERR="The number of admin times entered is fewer than indicated by the schedule." Q ;Too few times
- I ERR]"" D DISPLAY Q
- D ENCHK^PSGS0
- I '$D(X) S ERR="Schedule/Admin times failed validation" D DISPLAY
- Q
- ;
- HEAD ;Header.
- W:$Y @IOF S PSJPAG=PSJPAG+1
- W PSJDATE,?47,"Inpatient Medications Schedule Issues",?120,"PAGE: ",PSJPAG,!! W !,"PATIENT",?20,"SSN",?33,"START DATE",?52,"STOP DATE",?71,"SCHEDULE",?91,"TYPE",?96,"ADMIN TIMES"
- W !,UL132
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJVOSR 3983 printed Mar 13, 2025@21:14:08 Page 2
- PSJVOSR ;BIR/DRF-PRINT ACTIVE ORDER SCHEDULE VALIDATION ;13 APR 09 / 5:26 PM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**113**;16 DEC 97;Build 63
- +2 ;
- +3 ; Reference to ^PS(55 is supported by DBIA 2191.
- +4 ; Reference to ^%ZTLOAD is supported by DBIA 10063.
- +5 ; Reference to ^%DTC is supported by DBIA 10000.
- +6 ; Reference to ^%ZIS is supported by DBIA 10086.
- +7 ; Reference to ^%ZISC is supported by DBIA 10089.
- +8 ; Reference to ^DIR is supported by DBIA 10026.
- +9 ;
- SELDEV ;Ask for device type for report to output to
- +1 KILL IOP,%ZIS,POP,IO("Q")
- +2 WRITE !
- SET %ZIS("A")="Select output device: "
- SET %ZIS("B")=""
- SET %ZIS="Q"
- +3 DO ^%ZIS
- IF POP
- WRITE !,"** No device selected **"
- GOTO EXIT
- +4 if '$DATA(IO("Q"))
- WRITE !,"this may take a while...(you should QUEUE this report)",!
- +5 IF $DATA(IO("Q"))
- Begin DoDot:1
- +6 SET XDESC="Problem Schedules on Orders"
- +7 SET ZTRTN="START^PSJVOSR"
- +8 KILL IO("Q"),ZTSAVE,ZTDTH,ZTSK
- +9 SET ZTDESC=XDESC
- SET PSGIO=ION
- SET ZTIO=PSGIO
- SET ZTDTH=$HOROLOG
- SET ZTSAVE("PSJSORT")=""
- SET %ZIS="QN"
- SET IOP=PSGIO
- +10 DO ^%ZIS
- DO ^%ZTLOAD
- End DoDot:1
- GOTO EXIT
- +11 ;
- START ;Loop through open orders.
- +1 DO NOW^%DTC
- SET UL132=""
- SET $PIECE(UL132,"-",132)=""
- SET PSJDATE=$$ENDTC^PSGMI(%)
- SET PSJPTR=$EXTRACT(IOST)'="C"
- SET PG=0
- SET PSIVAC="PH"
- SET PSJPAG=0
- +2 USE IO
- +3 DO HEAD
- +4 SET PSJTYP="U"
- +5 SET STPDT=$PIECE(%,".")-1
- FOR
- SET STPDT=$ORDER(^PS(55,"AUD",STPDT))
- if STPDT=""
- QUIT
- Begin DoDot:1
- +6 SET D0=""
- FOR
- SET D0=$ORDER(^PS(55,"AUD",STPDT,D0))
- if D0=""
- QUIT
- Begin DoDot:2
- +7 SET D1=""
- FOR
- SET D1=$ORDER(^PS(55,"AUD",STPDT,D0,D1))
- if D1=""
- QUIT
- Begin DoDot:3
- +8 DO TEST
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +9 SET PSJTYP="V"
- +10 SET STPDT=$PIECE(%,".")-1
- FOR
- SET STPDT=$ORDER(^PS(55,"AIV",STPDT))
- if STPDT=""
- QUIT
- Begin DoDot:1
- +11 SET D0=""
- FOR
- SET D0=$ORDER(^PS(55,"AIV",STPDT,D0))
- if D0=""
- QUIT
- Begin DoDot:2
- +12 SET D1=""
- FOR
- SET D1=$ORDER(^PS(55,"AIV",STPDT,D0,D1))
- if D1=""
- QUIT
- Begin DoDot:3
- +13 DO TEST
- End DoDot:3
- End DoDot:2
- End DoDot:1
- EXIT ;Kill and exit.
- +1 KILL %,%H,%I,%ZIS,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTRTN
- +2 KILL D0,D1,DONE,ERR,NAME,PG,PSGAT,PSGIO,PSGS0XT,PSGSCH,PSGSSP,PSGSST,PSGST
- +3 KILL PSIVAC,PSJDATE,PSJPAG,PSJPTR,PSJTYP,SPD,SSN,STD,STPDT,UL132,X,XDESC,Y
- +4 KILL ZTQUEUED,ZTREQ
- +5 if $EXTRACT(IOST)="C"&($Y)
- WRITE @IOF
- +6 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +7 SET IOP="HOME"
- DO ^%ZISC
- +8 QUIT
- +9 ;
- DISPLAY ;Display Name, last 4 of SS, order number, start date, stop date, schedule, schedule type, admin times, error.
- +1 SET NAME=$$GET1^DIQ(2,D0,.01,"O")
- +2 SET SSN="XXX-XX-"_$EXTRACT($$GET1^DIQ(2,D0,.09,"O"),6,9)
- +3 SET Y=PSGSST
- DO DD^%DT
- SET STD=Y
- +4 SET Y=PSGSSP
- DO DD^%DT
- SET SPD=Y
- +5 if ($Y+5)>IOSL
- DO HEAD
- +6 WRITE !,NAME,?20,SSN,?33,STD,?52,SPD,?71,PSGSCH,?91,$SELECT(+PSGS0XT:"C",1:PSGS0XT),?96,PSGAT,!,ERR
- +7 QUIT
- +8 ;
- PAUSE ;Hold screen.
- +1 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!($DATA(DUOUT))
- SET DONE=1
- +2 QUIT
- +3 ;
- TEST ;Check for errors.
- +1 NEW D12,MAX
- +2 IF PSJTYP="U"
- Begin DoDot:1
- +3 SET D12=$GET(^PS(55,D0,5,D1,2))
- +4 SET PSGSCH=$PIECE(D12,"^",1)
- SET (X,PSGAT)=$PIECE(D12,"^",5)
- SET PSGS0XT=$PIECE(D12,"^",6)
- SET PSGSST=$PIECE(D12,"^",2)
- SET PSGSSP=$PIECE(D12,"^",4)
- End DoDot:1
- +5 IF PSJTYP="V"
- Begin DoDot:1
- +6 SET D12=$GET(^PS(55,D0,"IV",D1,0))
- +7 SET PSGSCH=$PIECE(D12,"^",9)
- SET (X,PSGAT)=$PIECE(D12,"^",11)
- SET PSGS0XT=$PIECE(D12,"^",15)
- SET PSGSST=$PIECE(D12,"^",2)
- SET PSGSSP=$PIECE(D12,"^",3)
- End DoDot:1
- +8 IF PSGSCH[" PRN"
- SET PSGS0XT="P"
- +9 ;No times required or allowed for PRN
- IF PSGS0XT="P"
- Begin DoDot:1
- +10 IF X=""
- QUIT
- +11 SET ERR="Admin times not permitted for PRN schedule"
- +12 DO DISPLAY
- End DoDot:1
- QUIT
- +13 IF PSGS0XT="D"!(PSGS0XT)="OC"
- QUIT
- +14 SET PSGST=$SELECT(PSGS0XT?1.N:"C",1:PSGS0XT)
- +15 SET ERR=""
- Begin DoDot:1
- +16 IF X=""
- SET ERR="This order requires at least one administration time"
- QUIT
- +17 IF $GET(PSGS0XT)="O"
- IF $LENGTH(X,"-")>1
- SET ERR="This is a One Time Order - only one admin time is permitted."
- QUIT
- +18 ;No frequency - can not check frequency related items
- IF +PSGS0XT=0
- QUIT
- +19 SET MAX=1440/PSGS0XT
- +20 IF MAX<1
- Begin DoDot:2
- +21 IF $LENGTH(X,"-")'=1
- SET ERR="This order requires one admin time."
- QUIT
- End DoDot:2
- QUIT
- +22 ;Too many times
- IF MAX'<1
- IF $LENGTH(X,"-")>MAX
- SET ERR="The number of admin times entered is greater than indicated by the schedule."
- QUIT
- +23 ;Too few times
- IF MAX'<1
- IF $LENGTH(X,"-")<MAX
- SET ERR="The number of admin times entered is fewer than indicated by the schedule."
- QUIT
- End DoDot:1
- +24 IF ERR]""
- DO DISPLAY
- QUIT
- +25 DO ENCHK^PSGS0
- +26 IF '$DATA(X)
- SET ERR="Schedule/Admin times failed validation"
- DO DISPLAY
- +27 QUIT
- +28 ;
- HEAD ;Header.
- +1 if $Y
- WRITE @IOF
- SET PSJPAG=PSJPAG+1
- +2 WRITE PSJDATE,?47,"Inpatient Medications Schedule Issues",?120,"PAGE: ",PSJPAG,!!
- WRITE !,"PATIENT",?20,"SSN",?33,"START DATE",?52,"STOP DATE",?71,"SCHEDULE",?91,"TYPE",?96,"ADMIN TIMES"
- +3 WRITE !,UL132
- +4 QUIT
