ORY182 ;SLC/DAN Delete incorrect allergy orders ;5/20/03 15:44
;;3.0;ORDER ENTRY/RESULTS REPORTING;**182**;Dec 17, 1997
;
;DBIA SECTION
;10141 - XPDUTL
;10070 - XMD
;10061 - VADPT
;10063 - %ZTLOAD
;10013 - DIK
;2056 - DIQ
;10067 - XMA21
;10060 - Access to file 200
;10103 - XLFDT
;
POST ;Search for problems, produce report, fix problems
N ZTRTN,ZTIO,ZTDESC,ZTDTH,ZTSAVE,ZTSK
D BMES^XPDUTL("Starting allergy order clean-up in background...")
S ZTRTN="EN^ORY182",ZTIO="",ZTDESC="Allergy order clean up",ZTDTH=$H,ZTSAVE("DUZ")="" D ^%ZTLOAD
Q
;
EN ;Start here
N ORI,ORCNT
K ^TMP("ORALDAT",$J)
S ORCNT=0
S ORI=$$GETIEN(2980101) F S ORI=$O(^OR(100,ORI)) Q:'+ORI D
.I '$D(^OR(100,ORI,0)) D ERR Q ;Record missing 0 nodes.
.Q:$$NMSP^ORCD($P(^OR(100,ORI,0),U,14))'="GMRA" ;Stop if not an allergy order
.Q:$P(^OR(100,ORI,3),U,3)'=11 ;Stop if order doesn't have "unreleased" status
.Q:'('$D(^OR(100,ORI,4.5,"ID","TYPE"))&($D(^OR(100,ORI,4.5,"ID","OBSERVED")))) ;Stop if responses multiple doesn't match what we're looking for
.D STORE,FIX
D MAIL
K ^TMP("ORALDAT",$J)
Q
;
STORE ;Store information regarding order for mail message
N NAME,SSN,DFN,TEXT,VADM
S DFN=+$P(^OR(100,ORI,0),U,2)
D DEM^VADPT
S SSN=$E(+VADM(2),6,9)
S NAME=VADM(1)
S TEXT=$G(^OR(100,ORI,8,1,.1,1,0))
S ORCNT=ORCNT+1
S ^TMP("ORALDAT",$J,ORCNT)=NAME_U_SSN_U_$$GET1^DIQ(100,ORI,3,"E")_U_$$GET1^DIQ(100,ORI,4,"E")_U_TEXT
Q
;
FIX ;Delete the erroneous entry in file 100
N DA,DIK
S DA=ORI,DIK="^OR(100," D ^DIK ;*poof*
Q
;
MAIL ;Send mail message to initiator detailing results
N XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,ORTXT,ORJ,ORK,LINE,DIFROM
S XMDUZ="Allergy order clean up"
I $D(^XTMP("ORY182","XMY")) M XMY=^XTMP("ORY182","XMY") K ^XTMP("ORY182")
I '$D(XMY) S XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
S ORTXT(1)="The allergy order clean up process has finished.",ORTXT(2)="",ORK=3
I ORCNT=0&('$D(^TMP("ORALDAT",$J,"ERR"))) S ORTXT(3)="No problems found. No additional review is required."
I ORCNT'=0 D
.S ORTXT(3)="Following is information regarding orders that were deleted."
.S ORTXT(4)="Please review any findings to make sure the patient's"
.S ORTXT(5)="allergy information is correct. Information shown here was NOT transmitted"
.S ORTXT(6)="to the allergy package and may not have been correctly reported."
.S ORTXT(7)="",ORTXT(8)="Information below is patient name, last 4, who entered, date",ORTXT(9)="entered, and order text.",ORTXT(10)=""
.S ORK=11
.F ORJ=1:1:ORCNT D
..S LINE=^TMP("ORALDAT",$J,ORJ)
..S ORTXT(ORK)=$P(LINE,U)_" "_$P(LINE,U,2)_" "_$P(LINE,U,3)_" "_$P(LINE,U,4),ORK=ORK+1
..S ORTXT(ORK)=$P(LINE,U,5),ORK=ORK+1,ORTXT(ORK)="",ORK=ORK+1
I $D(^TMP("ORALDAT",$J,"ERR")) D
.S ORTXT(ORK)="The following internal entry numbers from file 100 are missing",ORK=ORK+1,ORTXT(ORK)="zero nodes. You need to review each entry and take corrective action.",ORK=ORK+1,ORTXT(ORK)="Log a NOIS if you need assistance."
.S ORK=ORK+1,ORTXT(ORK)=""
.S ORK=ORK+1,ORJ=0 F S ORJ=$O(^TMP("ORALDAT",$J,"ERR",ORJ)) Q:'+ORJ S ORTXT(ORK)=ORJ,ORK=ORK+1
S XMTEXT="ORTXT(",XMSUB="Patch OR*3*182 allergy order report"
D ^XMD
Q
;
PRE ;Obtain names to send mail message to
N XMDUZ,XMDUN,XMY,ORTXT,DIFROM
Q:$D(ZTQUEUED) ;Quit if being queued, can't ask for recipients
I +$G(DUZ)=0 D MES^XPDUTL("You must set your DUZ before installing this patch. Installation aborted!") S XPDABORT=1 Q
S ORTXT(1)="This patch produces a report of patients with potential allergy order"
S ORTXT(2)="problems. Patient charts must be reviewed to be certain that allergy"
S ORTXT(3)="information is correct. Please identify recipients for this report."
S ORTXT(4)=""
D BMES^XPDUTL(.ORTXT)
S XMDUZ=$G(DUZ)
S XMDUN=$$GET1^DIQ(200,$G(DUZ),.01)
D DEST^XMA21
I $D(XMOUT) D BMES^XPDUTL("The report will still run and will be sent to you for distribution.") Q ;quit if user doesn't identify any recipients
S ^XTMP("ORY182",0)=$$FMADD^XLFDT($$DT^XLFDT,30) ;auto-deletion in 30 days
M ^XTMP("ORY182","XMY")=XMY ;Move recipient list into XTMP for later use
Q
;
GETIEN(STDT) ;Find first IEN associated with given start date
N DONE,IEN
S (DONE,IEN)=0
F S STDT=$O(^OR(100,"AF",STDT)) Q:'+STDT!(DONE) D
.S IEN=0 F S IEN=$O(^OR(100,"AF",STDT,IEN)) Q:'+IEN I $O(^(IEN,0))=1 S DONE=1 Q ;Find first ORDER that is a new order
Q IEN
;
ERR ;Record missing 0 node errors
S ^TMP("ORALDAT",$J,"ERR",ORI)=""
Q
ORY182 ;SLC/DAN Delete incorrect allergy orders ;5/20/03 15:44
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**182**;Dec 17, 1997
+2 ;
+3 ;DBIA SECTION
+4 ;10141 - XPDUTL
+5 ;10070 - XMD
+6 ;10061 - VADPT
+7 ;10063 - %ZTLOAD
+8 ;10013 - DIK
+9 ;2056 - DIQ
+10 ;10067 - XMA21
+11 ;10060 - Access to file 200
+12 ;10103 - XLFDT
+13 ;
POST ;Search for problems, produce report, fix problems
+1 NEW ZTRTN,ZTIO,ZTDESC,ZTDTH,ZTSAVE,ZTSK
+2 DO BMES^XPDUTL("Starting allergy order clean-up in background...")
+3 SET ZTRTN="EN^ORY182"
SET ZTIO=""
SET ZTDESC="Allergy order clean up"
SET ZTDTH=$HOROLOG
SET ZTSAVE("DUZ")=""
DO ^%ZTLOAD
+4 QUIT
+5 ;
EN ;Start here
+1 NEW ORI,ORCNT
+2 KILL ^TMP("ORALDAT",$JOB)
+3 SET ORCNT=0
+4 SET ORI=$$GETIEN(2980101)
FOR
SET ORI=$ORDER(^OR(100,ORI))
IF '+ORI
QUIT
Begin DoDot:1
+5 ;Record missing 0 nodes.
IF '$DATA(^OR(100,ORI,0))
DO ERR
QUIT
+6 ;Stop if not an allergy order
IF $$NMSP^ORCD($PIECE(^OR(100,ORI,0),U,14))'="GMRA"
QUIT
+7 ;Stop if order doesn't have "unreleased" status
IF $PIECE(^OR(100,ORI,3),U,3)'=11
QUIT
+8 ;Stop if responses multiple doesn't match what we're looking for
IF '('$DATA(^OR(100,ORI,4.5,"ID","TYPE"))&($DATA(^OR(100,ORI,4.5,"ID","OBSERVED"))))
QUIT
+9 DO STORE
DO FIX
End DoDot:1
+10 DO MAIL
+11 KILL ^TMP("ORALDAT",$JOB)
+12 QUIT
+13 ;
STORE ;Store information regarding order for mail message
+1 NEW NAME,SSN,DFN,TEXT,VADM
+2 SET DFN=+$PIECE(^OR(100,ORI,0),U,2)
+3 DO DEM^VADPT
+4 SET SSN=$EXTRACT(+VADM(2),6,9)
+5 SET NAME=VADM(1)
+6 SET TEXT=$GET(^OR(100,ORI,8,1,.1,1,0))
+7 SET ORCNT=ORCNT+1
+8 SET ^TMP("ORALDAT",$JOB,ORCNT)=NAME_U_SSN_U_$$GET1^DIQ(100,ORI,3,"E")_U_$$GET1^DIQ(100,ORI,4,"E")_U_TEXT
+9 QUIT
+10 ;
FIX ;Delete the erroneous entry in file 100
+1 NEW DA,DIK
+2 ;*poof*
SET DA=ORI
SET DIK="^OR(100,"
DO ^DIK
+3 QUIT
+4 ;
MAIL ;Send mail message to initiator detailing results
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,ORTXT,ORJ,ORK,LINE,DIFROM
+2 SET XMDUZ="Allergy order clean up"
+3 IF $DATA(^XTMP("ORY182","XMY"))
MERGE XMY=^XTMP("ORY182","XMY")
KILL ^XTMP("ORY182")
+4 IF '$DATA(XMY)
SET XMY(.5)=""
IF $GET(DUZ)
SET XMY(DUZ)=""
+5 SET ORTXT(1)="The allergy order clean up process has finished."
SET ORTXT(2)=""
SET ORK=3
+6 IF ORCNT=0&('$DATA(^TMP("ORALDAT",$JOB,"ERR")))
SET ORTXT(3)="No problems found. No additional review is required."
+7 IF ORCNT'=0
Begin DoDot:1
+8 SET ORTXT(3)="Following is information regarding orders that were deleted."
+9 SET ORTXT(4)="Please review any findings to make sure the patient's"
+10 SET ORTXT(5)="allergy information is correct. Information shown here was NOT transmitted"
+11 SET ORTXT(6)="to the allergy package and may not have been correctly reported."
+12 SET ORTXT(7)=""
SET ORTXT(8)="Information below is patient name, last 4, who entered, date"
SET ORTXT(9)="entered, and order text."
SET ORTXT(10)=""
+13 SET ORK=11
+14 FOR ORJ=1:1:ORCNT
Begin DoDot:2
+15 SET LINE=^TMP("ORALDAT",$JOB,ORJ)
+16 SET ORTXT(ORK)=$PIECE(LINE,U)_" "_$PIECE(LINE,U,2)_" "_$PIECE(LINE,U,3)_" "_$PIECE(LINE,U,4)
SET ORK=ORK+1
+17 SET ORTXT(ORK)=$PIECE(LINE,U,5)
SET ORK=ORK+1
SET ORTXT(ORK)=""
SET ORK=ORK+1
End DoDot:2
End DoDot:1
+18 IF $DATA(^TMP("ORALDAT",$JOB,"ERR"))
Begin DoDot:1
+19 SET ORTXT(ORK)="The following internal entry numbers from file 100 are missing"
SET ORK=ORK+1
SET ORTXT(ORK)="zero nodes. You need to review each entry and take corrective action."
SET ORK=ORK+1
SET ORTXT(ORK)="Log a NOIS if you need assistance."
+20 SET ORK=ORK+1
SET ORTXT(ORK)=""
+21 SET ORK=ORK+1
SET ORJ=0
FOR
SET ORJ=$ORDER(^TMP("ORALDAT",$JOB,"ERR",ORJ))
IF '+ORJ
QUIT
SET ORTXT(ORK)=ORJ
SET ORK=ORK+1
End DoDot:1
+22 SET XMTEXT="ORTXT("
SET XMSUB="Patch OR*3*182 allergy order report"
+23 DO ^XMD
+24 QUIT
+25 ;
PRE ;Obtain names to send mail message to
+1 NEW XMDUZ,XMDUN,XMY,ORTXT,DIFROM
+2 ;Quit if being queued, can't ask for recipients
IF $DATA(ZTQUEUED)
QUIT
+3 IF +$GET(DUZ)=0
DO MES^XPDUTL("You must set your DUZ before installing this patch. Installation aborted!")
SET XPDABORT=1
QUIT
+4 SET ORTXT(1)="This patch produces a report of patients with potential allergy order"
+5 SET ORTXT(2)="problems. Patient charts must be reviewed to be certain that allergy"
+6 SET ORTXT(3)="information is correct. Please identify recipients for this report."
+7 SET ORTXT(4)=""
+8 DO BMES^XPDUTL(.ORTXT)
+9 SET XMDUZ=$GET(DUZ)
+10 SET XMDUN=$$GET1^DIQ(200,$GET(DUZ),.01)
+11 DO DEST^XMA21
+12 ;quit if user doesn't identify any recipients
IF $DATA(XMOUT)
DO BMES^XPDUTL("The report will still run and will be sent to you for distribution.")
QUIT
+13 ;auto-deletion in 30 days
SET ^XTMP("ORY182",0)=$$FMADD^XLFDT($$DT^XLFDT,30)
+14 ;Move recipient list into XTMP for later use
MERGE ^XTMP("ORY182","XMY")=XMY
+15 QUIT
+16 ;
GETIEN(STDT) ;Find first IEN associated with given start date
+1 NEW DONE,IEN
+2 SET (DONE,IEN)=0
+3 FOR
SET STDT=$ORDER(^OR(100,"AF",STDT))
IF '+STDT!(DONE)
QUIT
Begin DoDot:1
+4 ;Find first ORDER that is a new order
SET IEN=0
FOR
SET IEN=$ORDER(^OR(100,"AF",STDT,IEN))
IF '+IEN
QUIT
IF $ORDER(^(IEN,0))=1
SET DONE=1
QUIT
End DoDot:1
+5 QUIT IEN
+6 ;
ERR ;Record missing 0 node errors
+1 SET ^TMP("ORALDAT",$JOB,"ERR",ORI)=""
+2 QUIT
