GMPLP37I ; SLC/MKB/KER -- Save Problem List data ; 10/01/2008
;;2.0;Problem List;**37**;Aug 25, 1994;Build 1
;
; External References
;
FIND(ACTION) ;
N ARRAY,CNT,DAT,IEN,PL,PRI,PT,STAT
S CNT=0
S PT=0 F S PT=$O(^PXRMINDX(9000011,"PSPI",PT)) Q:PT'>0 D
.S STAT=""
.F S STAT=$O(^PXRMINDX(9000011,"PSPI",PT,STAT)) Q:STAT="" D
..I '$D(^PXRMINDX(9000011,"PSPI",PT,STAT,0)) Q
..S PL=0
..F S PL=$O(^PXRMINDX(9000011,"PSPI",PT,STAT,0,PL)) Q:PL'>0 D
...S DAT=0
...F S DAT=$O(^PXRMINDX(9000011,"PSPI",PT,STAT,0,PL,DAT)) Q:DAT'>0 D
....S IEN=0
....F S IEN=$O(^PXRMINDX(9000011,"PSPI",PT,STAT,0,PL,DAT,IEN)) Q:IEN'>0 D
.....S CNT=CNT+1
.....I ACTION=1 S ARRAY(CNT)=IEN
I ACTION=1 D UPD(.ARRAY)
Q CNT
;
POST ;
N ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,TEXT,ZTSK
S ZTDESC="Correction to the Priority field in the PROBLEM file"
S TEXT=ZTDESC_" has been queued, task number "
S ZTRTN="QUEUED^GMPLP37I"
S ZTIO=""
S ZTDTH=$$NOW^XLFDT
S ZTREQ="@"
D ^%ZTLOAD
I $D(ZTSK) S TEXT=TEXT_ZTSK D MES^XPDUTL(.TEXT)
Q
QUEUED ;
N ARRAY,AFTER,BEFORE,CHANGE,CNT
S CNT=0
S BEFORE=$$FIND(0)
I BEFORE=0 D G SEND
.S CNT=CNT+1,ARRAY(CNT,0)="No invalid entries found in the PROBLEM file."
S CNT=CNT+1,ARRAY(CNT,0)="Initial count of invalid entries in the PROBLEM file."
S CNT=CNT+1,ARRAY(CNT,0)=" "_BEFORE_" Invalid entries in the PROBLEM file."
S CNT=CNT+1,ARRAY(CNT,0)=" "
S CHANGE=$$FIND(1)
S CNT=CNT+1,ARRAY(CNT,0)="Number of entries that were change."
S CNT=CNT+1,ARRAY(CNT,0)=" "_CHANGE_" entries in the PROBLEM file corrected."
S CNT=CNT+1,ARRAY(CNT,0)=" "
S AFTER=$$FIND(0)
S CNT=CNT+1,ARRAY(CNT,0)="Count of entries that are still invalid."
S CNT=CNT+1,ARRAY(CNT,0)=" "_AFTER_" Invalid entries in the PROBLEM file."
;
SEND ;mailman
N NL,XMDUZ,XMY,XMZ
S XMSUB="Correction of invalid entries in the PROBLEM file"
S XMDUZ=0.5
;
RETRY ;Get the message number.
D XMZ^XMA2
I XMZ<1 G RETRY
;
;Load the message
M ^XMB(3.9,XMZ,2)=ARRAY
S NL=$O(^XMB(3.9,XMZ,2,""),-1)
S ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
;
;Send message to USER
S XMY(DUZ)="" D ENT1^XMD Q
Q
;
UPD(ARRAY) ;
N CNT,DA,DIE,DR
S DIE="^AUPNPROB(",DR="1.14///@"
S CNT=0 F S CNT=$O(ARRAY(CNT)) Q:CNT'>0 D
.S DA=ARRAY(CNT)
.D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLP37I 2310 printed Nov 22, 2024@17:40:16 Page 2
GMPLP37I ; SLC/MKB/KER -- Save Problem List data ; 10/01/2008
+1 ;;2.0;Problem List;**37**;Aug 25, 1994;Build 1
+2 ;
+3 ; External References
+4 ;
FIND(ACTION) ;
+1 NEW ARRAY,CNT,DAT,IEN,PL,PRI,PT,STAT
+2 SET CNT=0
+3 SET PT=0
FOR
SET PT=$ORDER(^PXRMINDX(9000011,"PSPI",PT))
if PT'>0
QUIT
Begin DoDot:1
+4 SET STAT=""
+5 FOR
SET STAT=$ORDER(^PXRMINDX(9000011,"PSPI",PT,STAT))
if STAT=""
QUIT
Begin DoDot:2
+6 IF '$DATA(^PXRMINDX(9000011,"PSPI",PT,STAT,0))
QUIT
+7 SET PL=0
+8 FOR
SET PL=$ORDER(^PXRMINDX(9000011,"PSPI",PT,STAT,0,PL))
if PL'>0
QUIT
Begin DoDot:3
+9 SET DAT=0
+10 FOR
SET DAT=$ORDER(^PXRMINDX(9000011,"PSPI",PT,STAT,0,PL,DAT))
if DAT'>0
QUIT
Begin DoDot:4
+11 SET IEN=0
+12 FOR
SET IEN=$ORDER(^PXRMINDX(9000011,"PSPI",PT,STAT,0,PL,DAT,IEN))
if IEN'>0
QUIT
Begin DoDot:5
+13 SET CNT=CNT+1
+14 IF ACTION=1
SET ARRAY(CNT)=IEN
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF ACTION=1
DO UPD(.ARRAY)
+16 QUIT CNT
+17 ;
POST ;
+1 NEW ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,TEXT,ZTSK
+2 SET ZTDESC="Correction to the Priority field in the PROBLEM file"
+3 SET TEXT=ZTDESC_" has been queued, task number "
+4 SET ZTRTN="QUEUED^GMPLP37I"
+5 SET ZTIO=""
+6 SET ZTDTH=$$NOW^XLFDT
+7 SET ZTREQ="@"
+8 DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
SET TEXT=TEXT_ZTSK
DO MES^XPDUTL(.TEXT)
+10 QUIT
QUEUED ;
+1 NEW ARRAY,AFTER,BEFORE,CHANGE,CNT
+2 SET CNT=0
+3 SET BEFORE=$$FIND(0)
+4 IF BEFORE=0
Begin DoDot:1
+5 SET CNT=CNT+1
SET ARRAY(CNT,0)="No invalid entries found in the PROBLEM file."
End DoDot:1
GOTO SEND
+6 SET CNT=CNT+1
SET ARRAY(CNT,0)="Initial count of invalid entries in the PROBLEM file."
+7 SET CNT=CNT+1
SET ARRAY(CNT,0)=" "_BEFORE_" Invalid entries in the PROBLEM file."
+8 SET CNT=CNT+1
SET ARRAY(CNT,0)=" "
+9 SET CHANGE=$$FIND(1)
+10 SET CNT=CNT+1
SET ARRAY(CNT,0)="Number of entries that were change."
+11 SET CNT=CNT+1
SET ARRAY(CNT,0)=" "_CHANGE_" entries in the PROBLEM file corrected."
+12 SET CNT=CNT+1
SET ARRAY(CNT,0)=" "
+13 SET AFTER=$$FIND(0)
+14 SET CNT=CNT+1
SET ARRAY(CNT,0)="Count of entries that are still invalid."
+15 SET CNT=CNT+1
SET ARRAY(CNT,0)=" "_AFTER_" Invalid entries in the PROBLEM file."
+16 ;
SEND ;mailman
+1 NEW NL,XMDUZ,XMY,XMZ
+2 SET XMSUB="Correction of invalid entries in the PROBLEM file"
+3 SET XMDUZ=0.5
+4 ;
RETRY ;Get the message number.
+1 DO XMZ^XMA2
+2 IF XMZ<1
GOTO RETRY
+3 ;
+4 ;Load the message
+5 MERGE ^XMB(3.9,XMZ,2)=ARRAY
+6 SET NL=$ORDER(^XMB(3.9,XMZ,2,""),-1)
+7 SET ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
+8 ;
+9 ;Send message to USER
+10 SET XMY(DUZ)=""
DO ENT1^XMD
QUIT
+11 QUIT
+12 ;
UPD(ARRAY) ;
+1 NEW CNT,DA,DIE,DR
+2 SET DIE="^AUPNPROB("
SET DR="1.14///@"
+3 SET CNT=0
FOR
SET CNT=$ORDER(ARRAY(CNT))
if CNT'>0
QUIT
Begin DoDot:1
+4 SET DA=ARRAY(CNT)
+5 DO ^DIE
End DoDot:1
+6 QUIT
