- 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