- ORY299 ;SLC/JLC-Search for truncated Patient Instructions ;02/26/08 09:21
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**299**;Dec 17, 1997;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- EN1 ;
- I $G(DUZ)="" W "Your DUZ is not defined.",! Q
- N ZTDESC,ZTIO,ZTRTN,ZTSK,ZTSAVE
- TASK S ZTRTN="EN^ORY299",ZTIO=""
- S ZTDESC="Check for Truncated Patient Instructions"
- D ^%ZTLOAD
- W !!,"The check for truncated Patient Instructions is",$S($D(ZTSK):"",1:" NOT")," queued",!
- I $D(ZTSK) W " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
- Q
- ;
- EN ; -- tasked entry point
- S:$D(ZTQUEUED) ZTREQ="@"
- N CREAT,EXPR,OI,STOP,S1,X1,X2,X,OIEN,PSOP,A,S2,S3,B,DFN,PKGR,DIV,%,RXD,LASTS3,SET,UPD,IDFN,ORN,START
- D NOW^%DTC S CREAT=$E(%,1,7),EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0) K ^XTMP("ORY281A")
- S X1=%,X2=-366 D C^%DTC S S1=X
- ; .9.4 reference - DBIA # 2058
- ; PXRMINDX reference - DBIA # 4290
- ; PSRX reference - DBIA #5205
- S PSOP=$O(^DIC(9.4,"B","OUTPATIENT PHARMACY",""))
- S OI=0 F S OI=$O(^PXRMINDX(52,"IP",OI)) Q:'OI D
- . S IDFN=0 F S IDFN=$O(^PXRMINDX(52,"IP",OI,IDFN)) Q:'IDFN D
- .. S START=0 F S START=$O(^PXRMINDX(52,"IP",OI,IDFN,START)) Q:'START D
- ... S STOP=S1 F S STOP=$O(^PXRMINDX(52,"IP",OI,IDFN,START,STOP)) Q:'STOP D
- .... S ORN=0 F S ORN=$O(^PXRMINDX(52,"IP",OI,IDFN,START,STOP,ORN)) Q:'ORN S OIEN=$P(^PSRX(+ORN,"OR1"),"^",2),UPD=0 I OIEN]"" D
- ..... S A=$G(^OR(100,OIEN,0)) Q:$P(A,"^",14)'=PSOP
- ..... S S2=$O(^OR(100,OIEN,4.5,"ID","PI","")) Q:S2=""
- ..... S DFN=$P($P(A,"^",2),";"),PKGR=$G(^OR(100,OIEN,4)) Q:PKGR="" D EN^PSOORDER(DFN,PKGR) Q:'$D(^TMP("PSOR",$J))
- ..... S DIV=$P(^TMP("PSOR",$J,PKGR,1),"^",7),S3=0 F B=1:1 Q:'$D(^TMP("PSOR",$J,PKGR,"PI",B,0)) S RXD=^(0),S3=$O(^OR(100,OIEN,4.5,S2,2,S3)) D Q:UPD
- ...... I S3]"" S LASTS3=S3
- ...... I S3="" D UPDATE S UPD=1 Q
- ...... I $G(^OR(100,OIEN,4.5,S2,2,S3,0))'=$G(^TMP("PSOR",$J,PKGR,"PI",B,0)) D UPDATE S UPD=1
- I $D(^XTMP("ORY281A")) S ^XTMP("ORY281A",0)=EXPR_"^"_CREAT
- D SEND
- K ZTQUEUED,ZTREQ Q
- UPDATE ;Update OR file and record problem order number
- S ^XTMP("ORY281A",DIV,OIEN)=$P(^TMP("PSOR",$J,PKGR,0),"^",5)_"^"_$P($P(^TMP("PSOR",$J,PKGR,"DRUG",0),"^"),";",2)
- S A=$G(^OR(100,OIEN,4.5,S2,2,0)) K ^OR(100,OIEN,4.5,S2,2)
- M ^OR(100,OIEN,4.5,S2,2)=^TMP("PSOR",$J,PKGR,"PI")
- S SET=$O(^OR(100,OIEN,4.5,S2,2,""),-1),$P(A,"^",3)=SET,$P(A,"^",4)=SET,^OR(100,OIEN,4.5,S2,2,0)=A
- Q
- SEND ;Send message
- K ORMSG,XMY N OCNT,OIEN,A,XMDUZ,XMSUB,XMTEXT,OIP,DIV,SP,DVNM,STATUS,STOP,OI,RX,DD
- S XMDUZ="CPRS, SEARCH",XMSUB="TRUNCATED PATIENT INSTRUCTIONS",XMTEXT="ORMSG(",XMY(DUZ)=""
- S ORMSG(1,0)=" The check for truncated Patient Instructions is complete."
- S ORMSG(2,0)=" ",ORMSG(3,0)=" Here is the list of the affected orders: ",ORMSG(4,0)=" "
- S (DIV,OIEN)=0,ORMSG(5,0)="Patient/Division SSN Item/Dispense Status/RX# Stop/OIEN",OCNT=5,SP=$J(" ",50)
- I '$D(^XTMP("ORY281A")) S OCNT=OCNT+1,ORMSG(OCNT,0)="No orders found."
- F S DIV=$O(^XTMP("ORY281A",DIV)) Q:DIV="" D PSS^PSO59(DIV,,"ORY281A") S DVNM=^TMP($J,"ORY281A",DIV,.01) D
- . F S OIEN=$O(^XTMP("ORY281A",DIV,OIEN)) Q:OIEN="" S A=^(OIEN),RX=$P(A,"^"),DD=$P(A,"^",2) D
- .. S A=$G(^OR(100,OIEN,0)),DFN=$P($P(A,"^",2),";"),STOP=$P(A,"^",9),STOP=$E(STOP,4,5)_"/"_$E(STOP,6,7)_"/"_($E(STOP,1,3)+1700)_" "_$E(STOP,9,10)
- .. S A=^DPT(DFN,0),STATUS=$P($G(^OR(100,OIEN,3)),"^",3),STATUS=$P($G(^ORD(100.01,STATUS,0)),"^")
- .. S OIP=$O(^OR(100,OIEN,4.5,"ID","ORDERABLE","")),OI=$G(^OR(100,OIEN,4.5,OIP,1)),OI=$P($G(^ORD(101.43,OI,0)),"^")
- .. S OCNT=OCNT+1,ORMSG(OCNT,0)=$E($P(A,"^")_SP,1,20)_" "_$E($P(A,"^",9),6,9)_" "_$E(OI_SP,1,20)_" "_$E(STATUS_SP,1,13)_" "_STOP
- .. S OCNT=OCNT+1,ORMSG(OCNT,0)=$E(DVNM_SP,1,26)_" "_$E(DD_SP,1,20)_" "_$E(RX_SP,1,13)_" "_OIEN
- .. S OCNT=OCNT+1,ORMSG(OCNT,0)=" "
- D ^XMD
- Q
- ORY299 ;SLC/JLC-Search for truncated Patient Instructions ;02/26/08 09:21
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**299**;Dec 17, 1997;Build 21
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- EN1 ;
- +1 IF $GET(DUZ)=""
- WRITE "Your DUZ is not defined.",!
- QUIT
- +2 NEW ZTDESC,ZTIO,ZTRTN,ZTSK,ZTSAVE
- TASK SET ZTRTN="EN^ORY299"
- SET ZTIO=""
- +1 SET ZTDESC="Check for Truncated Patient Instructions"
- +2 DO ^%ZTLOAD
- +3 WRITE !!,"The check for truncated Patient Instructions is",$SELECT($DATA(ZTSK):"",1:" NOT")," queued",!
- +4 IF $DATA(ZTSK)
- WRITE " (to start NOW).",!!,"YOU WILL RECEIVE A MAILMAN MESSAGE WHEN TASK #"_ZTSK_" HAS COMPLETED."
- +5 QUIT
- +6 ;
- EN ; -- tasked entry point
- +1 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +2 NEW CREAT,EXPR,OI,STOP,S1,X1,X2,X,OIEN,PSOP,A,S2,S3,B,DFN,PKGR,DIV,%,RXD,LASTS3,SET,UPD,IDFN,ORN,START
- +3 DO NOW^%DTC
- SET CREAT=$EXTRACT(%,1,7)
- SET EXPR=$$FMADD^XLFDT(CREAT,30,0,0,0)
- KILL ^XTMP("ORY281A")
- +4 SET X1=%
- SET X2=-366
- DO C^%DTC
- SET S1=X
- +5 ; .9.4 reference - DBIA # 2058
- +6 ; PXRMINDX reference - DBIA # 4290
- +7 ; PSRX reference - DBIA #5205
- +8 SET PSOP=$ORDER(^DIC(9.4,"B","OUTPATIENT PHARMACY",""))
- +9 SET OI=0
- FOR
- SET OI=$ORDER(^PXRMINDX(52,"IP",OI))
- IF 'OI
- QUIT
- Begin DoDot:1
- +10 SET IDFN=0
- FOR
- SET IDFN=$ORDER(^PXRMINDX(52,"IP",OI,IDFN))
- IF 'IDFN
- QUIT
- Begin DoDot:2
- +11 SET START=0
- FOR
- SET START=$ORDER(^PXRMINDX(52,"IP",OI,IDFN,START))
- IF 'START
- QUIT
- Begin DoDot:3
- +12 SET STOP=S1
- FOR
- SET STOP=$ORDER(^PXRMINDX(52,"IP",OI,IDFN,START,STOP))
- IF 'STOP
- QUIT
- Begin DoDot:4
- +13 SET ORN=0
- FOR
- SET ORN=$ORDER(^PXRMINDX(52,"IP",OI,IDFN,START,STOP,ORN))
- IF 'ORN
- QUIT
- SET OIEN=$PIECE(^PSRX(+ORN,"OR1"),"^",2)
- SET UPD=0
- IF OIEN]""
- Begin DoDot:5
- +14 SET A=$GET(^OR(100,OIEN,0))
- IF $PIECE(A,"^",14)'=PSOP
- QUIT
- +15 SET S2=$ORDER(^OR(100,OIEN,4.5,"ID","PI",""))
- IF S2=""
- QUIT
- +16 SET DFN=$PIECE($PIECE(A,"^",2),";")
- SET PKGR=$GET(^OR(100,OIEN,4))
- IF PKGR=""
- QUIT
- DO EN^PSOORDER(DFN,PKGR)
- IF '$DATA(^TMP("PSOR",$JOB))
- QUIT
- +17 SET DIV=$PIECE(^TMP("PSOR",$JOB,PKGR,1),"^",7)
- SET S3=0
- FOR B=1:1
- IF '$DATA(^TMP("PSOR",$JOB,PKGR,"PI",B,0))
- QUIT
- SET RXD=^(0)
- SET S3=$ORDER(^OR(100,OIEN,4.5,S2,2,S3))
- Begin DoDot:6
- +18 IF S3]""
- SET LASTS3=S3
- +19 IF S3=""
- DO UPDATE
- SET UPD=1
- QUIT
- +20 IF $GET(^OR(100,OIEN,4.5,S2,2,S3,0))'=$GET(^TMP("PSOR",$JOB,PKGR,"PI",B,0))
- DO UPDATE
- SET UPD=1
- End DoDot:6
- IF UPD
- QUIT
- End DoDot:5
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 IF $DATA(^XTMP("ORY281A"))
- SET ^XTMP("ORY281A",0)=EXPR_"^"_CREAT
- +22 DO SEND
- +23 KILL ZTQUEUED,ZTREQ
- QUIT
- UPDATE ;Update OR file and record problem order number
- +1 SET ^XTMP("ORY281A",DIV,OIEN)=$PIECE(^TMP("PSOR",$JOB,PKGR,0),"^",5)_"^"_$PIECE($PIECE(^TMP("PSOR",$JOB,PKGR,"DRUG",0),"^"),";",2)
- +2 SET A=$GET(^OR(100,OIEN,4.5,S2,2,0))
- KILL ^OR(100,OIEN,4.5,S2,2)
- +3 MERGE ^OR(100,OIEN,4.5,S2,2)=^TMP("PSOR",$JOB,PKGR,"PI")
- +4 SET SET=$ORDER(^OR(100,OIEN,4.5,S2,2,""),-1)
- SET $PIECE(A,"^",3)=SET
- SET $PIECE(A,"^",4)=SET
- SET ^OR(100,OIEN,4.5,S2,2,0)=A
- +5 QUIT
- SEND ;Send message
- +1 KILL ORMSG,XMY
- NEW OCNT,OIEN,A,XMDUZ,XMSUB,XMTEXT,OIP,DIV,SP,DVNM,STATUS,STOP,OI,RX,DD
- +2 SET XMDUZ="CPRS, SEARCH"
- SET XMSUB="TRUNCATED PATIENT INSTRUCTIONS"
- SET XMTEXT="ORMSG("
- SET XMY(DUZ)=""
- +3 SET ORMSG(1,0)=" The check for truncated Patient Instructions is complete."
- +4 SET ORMSG(2,0)=" "
- SET ORMSG(3,0)=" Here is the list of the affected orders: "
- SET ORMSG(4,0)=" "
- +5 SET (DIV,OIEN)=0
- SET ORMSG(5,0)="Patient/Division SSN Item/Dispense Status/RX# Stop/OIEN"
- SET OCNT=5
- SET SP=$JUSTIFY(" ",50)
- +6 IF '$DATA(^XTMP("ORY281A"))
- SET OCNT=OCNT+1
- SET ORMSG(OCNT,0)="No orders found."
- +7 FOR
- SET DIV=$ORDER(^XTMP("ORY281A",DIV))
- IF DIV=""
- QUIT
- DO PSS^PSO59(DIV,,"ORY281A")
- SET DVNM=^TMP($JOB,"ORY281A",DIV,.01)
- Begin DoDot:1
- +8 FOR
- SET OIEN=$ORDER(^XTMP("ORY281A",DIV,OIEN))
- IF OIEN=""
- QUIT
- SET A=^(OIEN)
- SET RX=$PIECE(A,"^")
- SET DD=$PIECE(A,"^",2)
- Begin DoDot:2
- +9 SET A=$GET(^OR(100,OIEN,0))
- SET DFN=$PIECE($PIECE(A,"^",2),";")
- SET STOP=$PIECE(A,"^",9)
- SET STOP=$EXTRACT(STOP,4,5)_"/"_$EXTRACT(STOP,6,7)_"/"_($EXTRACT(STOP,1,3)+1700)_" "_$EXTRACT(STOP,9,10)
- +10 SET A=^DPT(DFN,0)
- SET STATUS=$PIECE($GET(^OR(100,OIEN,3)),"^",3)
- SET STATUS=$PIECE($GET(^ORD(100.01,STATUS,0)),"^")
- +11 SET OIP=$ORDER(^OR(100,OIEN,4.5,"ID","ORDERABLE",""))
- SET OI=$GET(^OR(100,OIEN,4.5,OIP,1))
- SET OI=$PIECE($GET(^ORD(101.43,OI,0)),"^")
- +12 SET OCNT=OCNT+1
- SET ORMSG(OCNT,0)=$EXTRACT($PIECE(A,"^")_SP,1,20)_" "_$EXTRACT($PIECE(A,"^",9),6,9)_" "_$EXTRACT(OI_SP,1,20)_" "_$EXTRACT(STATUS_SP,1,13)_" "_STOP
- +13 SET OCNT=OCNT+1
- SET ORMSG(OCNT,0)=$EXTRACT(DVNM_SP,1,26)_" "_$EXTRACT(DD_SP,1,20)_" "_$EXTRACT(RX_SP,1,13)_" "_OIEN
- +14 SET OCNT=OCNT+1
- SET ORMSG(OCNT,0)=" "
- End DoDot:2
- End DoDot:1
- +15 DO ^XMD
- +16 QUIT
