SDEC820P ;ALB/MGD,BWF - SD*5.3*820 Post Init Routine ; June 28, 2022@14:03
;;5.3;SCHEDULING;**820**;AUG 13, 1993;Build 10
;;Per VHA Directive 6402, this routine should not be modified
;
D FIND,ADD,TASK
Q
;
FIND ;FIND THE IEN FOR "VS GUI NATIONAL"
N SDECDA,SDECDA1
D MES^XPDUTL("Updating SDEC SETTINGS file (#409.98)")
S SDECDA=0,SDECDA=$O(^SDEC(409.98,"B","VS GUI NATIONAL",SDECDA)) G:$G(SDECDA)="" NOFIND
D VERSION ;update GUI version number and date
Q
VERSION ;SET THE NEW VERSION UPDATE IN SDEC SETTING FILE #409.98 TO 1.7.28
S DA=SDECDA,DIE=409.98,DR="2///1.7.28;3///"_DT D ^DIE ;update VS GUI NATIONAL
K DIE,DR,DA
S SDECDA1=0,SDECDA1=$O(^SDEC(409.98,"B","VS GUI LOCAL",SDECDA1)) Q:$G(SDECDA1)="" ;get DA for the VS GUI LOCAL
S DA=SDECDA1,DIE=409.98,DR="2///1.7.28;3///"_DT D ^DIE ;update VS GUI LOCAL
K DIE,DR,DA
Q
;
NOFIND ;"VS GUI NATIONAL" NOT FOUND
D MES^XPDUTL("VS GUI NATIONAL not found in the SDEC SETTINGS file (#409.98)")
Q
TASK ;
D MSG("SD*5.3*820 Post-Install to fix missing check-in dates")
D MSG("in the SDEC APPOINTMENT (#409.84) file, and MRTC")
D MSG("intervals/sequence numbers in the SDEC APPT REQUEST")
D MSG("(#409.85) file is being tasked to run as a remote process.")
D MSG("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*820 Post Install Routine"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="VPS^SDEC820P",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MSG(">>>Task "_ZTSK_" has been queued.")
. D MSG("")
I '$D(ZTSK) D
. D MSG("UNABLE TO QUEUE THIS JOB.")
. D MSG("Please contact the National Help Desk to report this issue.")
Q
;
MSG(SDMES) ;
D BMES^XPDUTL(SDMES)
Q
VPS ;
N APTDT,APTIEN,RESOURCE,HOSPLOC,DFN,HLAPPT,CHKIN,STOPDT
S ^XTMP("SDEC820P",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Logging of repaired check-in times/MRTCs."
S ^XTMP("SDEC820P","VPS","CNT")=0
S STOPDT=$$NOW^XLFDT
S APTDT=0 F S APTDT=$O(^SDEC(409.84,"B",APTDT)) Q:'APTDT!(APTDT>STOPDT) D
.S APTIEN=0 F S APTIEN=$O(^SDEC(409.84,"B",APTDT,APTIEN)) Q:'APTIEN D
..; B index exists, but there is no data at the IEN.
..Q:'$D(^SDEC(409.84,APTIEN))
..; quit if checked in
..I $P(^SDEC(409.84,APTIEN,0),U,3) Q
..; If not checked out, quit
..I '$P($G(^SDEC(409.84,APTIEN,0)),U,14) Q
..; If cancelled, do not process
..I $P($G(^SDEC(409.84,APTIEN,0)),U,12) Q
..; quit if no-show
..I $P($G(^SDEC(409.84,APTIEN,0)),U,10) Q
..S RESOURCE=$P(^SDEC(409.84,APTIEN,0),U,7) Q:'RESOURCE
..Q:'$D(^SDEC(409.831,RESOURCE))
..S HOSPLOC=$P(^SDEC(409.831,RESOURCE,0),U,4)
..S DFN=$P(^SDEC(409.84,APTIEN,0),U,5)
..S HLAPPT=0
..F S HLAPPT=$O(^SC(HOSPLOC,"S",APTDT,1,HLAPPT)) Q:'HLAPPT D
...; quit if not the same patient
...I $P($G(^SC(HOSPLOC,"S",APTDT,1,HLAPPT,0)),U)'=DFN Q
...; quit if the appointment was cancelled
...I $P($G(^SC(HOSPLOC,"S",APTDT,1,HLAPPT,0)),U,9)]"" Q
...; quit if there is no check-in
...S CHKIN=$P($G(^SC(HOSPLOC,"S",APTDT,1,HLAPPT,"C")),U) Q:CHKIN']""
...S ^XTMP("SDEC820P","VPS",APTIEN,"BEFORE","CHECK-IN")=$P($G(^SDEC(409.84,APTIEN,0)),U,3)
...S ^XTMP("SDEC820P","VPS",APTIEN,"BEFORE","CHECK-IN ENTERED")=$P($G(^SDEC(409.84,APTIEN,0)),U,4)
...S $P(^SDEC(409.84,APTIEN,0),U,3)=CHKIN
...S $P(^SDEC(409.84,APTIEN,0),U,4)=CHKIN
...S ^XTMP("SDEC820P","VPS",APTIEN,"AFTER","CHECK-IN")=$P($G(^SDEC(409.84,APTIEN,0)),U,3)
...S ^XTMP("SDEC820P","VPS",APTIEN,"AFTER","CHECK-IN ENTERED")=$P($G(^SDEC(409.84,APTIEN,0)),U,4)
...S ^XTMP("SDEC820P","VPS",APTIEN,"SOURCE")=CHKIN
...S ^XTMP("SDEC820P","VPS","CNT")=$G(^XTMP("SDEC820P","VPS","CNT"))+1
;
; MRTC cleanup
N REQUESTIEN,PARENTIEN,SUBIEN,MIENS,COUNT,PARENTINTERVAL,MRTCCHILDIEN
S REQUESTIEN=0,COUNT=0
F S REQUESTIEN=$O(^SDEC(409.85,REQUESTIEN)) Q:'REQUESTIEN D
.;if this record is a parent request, get the mrtc children IENs
.I $P($G(^SDEC(409.85,REQUESTIEN,3)),U)=1,'$P($G(^SDEC(409.85,REQUESTIEN,3)),U,5) D
.S PARENTINTERVAL=$P($G(^SDEC(409.85,REQUESTIEN,3)),U,2)
.S DFN=$P($G(^SDEC(409.85,REQUESTIEN,0)),U)
.S SUBIEN=0,COUNT=0
.F S SUBIEN=$O(^SDEC(409.85,REQUESTIEN,2,SUBIEN)) Q:'SUBIEN D
..S COUNT=COUNT+1
..S MRTCCHILDIEN=$P($G(^SDEC(409.85,REQUESTIEN,2,SUBIEN,0)),U)
..S ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"BEFORE","INTERVAL")=$P($G(^SDEC(409.85,MRTCCHILDIEN,3)),U,2)
..S ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"BEFORE","CHILD SEQUENCE")=$P($G(^SDEC(409.85,MRTCCHILDIEN,3)),U,6)
..S $P(^SDEC(409.85,MRTCCHILDIEN,3),U,2)=PARENTINTERVAL
..S $P(^SDEC(409.85,MRTCCHILDIEN,3),U,6)=COUNT
..S ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"AFTER","INTERVAL")=$P($G(^SDEC(409.85,MRTCCHILDIEN,3)),U,2)
..S ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"AFTER","CHILD SEQUENCE")=$P($G(^SDEC(409.85,MRTCCHILDIEN,3)),U,6)
D MAIL
Q
MAIL ;
; Get Station Number
;
N STANUM,MESS1,XMTEXT,TEXT,XMSUB,XMY,XMDUZ,DIFROM
S STANUM=$$KSP^XUPARAM("INST")_","
S STANUM=$$GET1^DIQ(4,STANUM,99)
S MESS1="Station: "_STANUM_" - "
;
; Send MailMan message
S XMDUZ=DUZ
S XMTEXT="TEXT("
S TEXT(1)="The SD*5.3*820 post install has run to completion."
S TEXT(2)="The data was reviewed and updated without any issues."
S XMSUB=MESS1_"SD*5.3*820 - Post Install Update"
S XMDUZ=.5,XMY(DUZ)="",XMY(XMDUZ)=""
D ^XMD
Q
ADD ;** Add DSS IDs
;
; SDXX is in format:
; STOP CODE NAME^AMIS #^RESTRICTION TYPE^REST. DATE^CDR #
;
N SDX,SDXX
S SDVAR=1
D MES^XPDUTL("")
D BMES^XPDUTL(">>> Adding new Clinic Stops to CLINIC STOP File (#40.7)...")
;
;
D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 9/1/2022]")
S DIC(0)="L",DLAYGO=40.7,DIC="^DIC(40.7,"
F SDX=1:1 K DD,DO,DA S SDXX=$P($T(NEW+SDX),";;",2) Q:SDXX="QUIT" DO
.S DIC("DR")="1////"_$P(SDXX,"^",2)
.S DIC("DR")=DIC("DR")_";5////"_$P(SDXX,"^",3)_";6///"_$P(SDXX,"^",4)
.S X=$P(SDXX,"^",1)
.I '$D(^DIC(40.7,"C",$P(SDXX,"^",2))) D FILE^DICN,MESS Q
.I $D(^DIC(40.7,"C",$P(SDXX,"^",2))) D EDIT(SDXX),MESSEX
K DIC,DLAYGO,X
Q
;
NEW ;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
;;REGISTRY EXAM CVT PT SITE^497^S^9/1/2022
;;REGISTRY EXAM CVT PROV SITE^498^S^9/1/2022
;;QUIT
;
MESS ;** Add message
N ECXADMSG
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S ECXADMSG="Added: "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")
I $P(SDXX,"^",5)'="" S ECXADMSG=ECXADMSG_" [CDR#: "_$P(SDXX,"^",5)_"]"
D MES^XPDUTL(ECXADMSG)
I $P(SDXX,"^",3)'="" S ECXADMSG=" Restricted Type: "_$P(SDXX,"^",3)_" Restricted Date: "_$P(SDXX,"^",4)
D MES^XPDUTL(ECXADMSG)
K SDVAR
Q
;
MESSEX ;** Display message if stop code already exists
N ECXADMSG
I +$G(SDVAR) D HDR(SDVAR)
D MES^XPDUTL(" ")
S ECXADMSG=" "_$P(SDXX,"^",2)_" "_$P(SDXX,"^")_" already exists."
D MES^XPDUTL(ECXADMSG)
K SDVAR
Q
;
EDIT(SDXX) ;- Edit fields w/new values if stop code record already exists
;
Q:$G(SDXX)=""
N DA,DIE,DLAYGO,DR
S DA=+$O(^DIC(40.7,"C",+$P(SDXX,"^",2),0))
Q:'DA
S DIE="^DIC(40.7,",DR=".01///"_$P(SDXX,"^")_";1///"_$P(SDXX,"^",2)_";2///@"_$S('+$P(SDXX,U,5):"",1:";4///"_$P(SDXX,"^",5))_";5///"_$P(SDXX,"^",3)_";6///"_$P(SDXX,"^",4)
D ^DIE
Q
HDR(SDVAR) ;- Header
Q:'$G(SDVAR)
N SDHDR
S SDHDR=$P($T(@("HDR"_SDVAR)),";;",2)
D BMES^XPDUTL(SDHDR)
Q
;
;
HDR1 ;; Stop Code Name
;
HDR2 ;; CDR Stop Code Name
;
HDR3 ;; Stop Code Name Rest. Type Date
;
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC820P 7479 printed Apr 09, 2024@21:52:48 Page 2
SDEC820P ;ALB/MGD,BWF - SD*5.3*820 Post Init Routine ; June 28, 2022@14:03
+1 ;;5.3;SCHEDULING;**820**;AUG 13, 1993;Build 10
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 DO FIND
DO ADD
DO TASK
+5 QUIT
+6 ;
FIND ;FIND THE IEN FOR "VS GUI NATIONAL"
+1 NEW SDECDA,SDECDA1
+2 DO MES^XPDUTL("Updating SDEC SETTINGS file (#409.98)")
+3 SET SDECDA=0
SET SDECDA=$ORDER(^SDEC(409.98,"B","VS GUI NATIONAL",SDECDA))
if $GET(SDECDA)=""
GOTO NOFIND
+4 ;update GUI version number and date
DO VERSION
+5 QUIT
VERSION ;SET THE NEW VERSION UPDATE IN SDEC SETTING FILE #409.98 TO 1.7.28
+1 ;update VS GUI NATIONAL
SET DA=SDECDA
SET DIE=409.98
SET DR="2///1.7.28;3///"_DT
DO ^DIE
+2 KILL DIE,DR,DA
+3 ;get DA for the VS GUI LOCAL
SET SDECDA1=0
SET SDECDA1=$ORDER(^SDEC(409.98,"B","VS GUI LOCAL",SDECDA1))
if $GET(SDECDA1)=""
QUIT
+4 ;update VS GUI LOCAL
SET DA=SDECDA1
SET DIE=409.98
SET DR="2///1.7.28;3///"_DT
DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
+7 ;
NOFIND ;"VS GUI NATIONAL" NOT FOUND
+1 DO MES^XPDUTL("VS GUI NATIONAL not found in the SDEC SETTINGS file (#409.98)")
+2 QUIT
TASK ;
+1 DO MSG("SD*5.3*820 Post-Install to fix missing check-in dates")
+2 DO MSG("in the SDEC APPOINTMENT (#409.84) file, and MRTC")
+3 DO MSG("intervals/sequence numbers in the SDEC APPT REQUEST")
+4 DO MSG("(#409.85) file is being tasked to run as a remote process.")
+5 DO MSG("")
+6 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+7 SET ZTDESC="SD*5.3*820 Post Install Routine"
+8 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="VPS^SDEC820P"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
Begin DoDot:1
+10 DO MSG(">>>Task "_ZTSK_" has been queued.")
+11 DO MSG("")
End DoDot:1
+12 IF '$DATA(ZTSK)
Begin DoDot:1
+13 DO MSG("UNABLE TO QUEUE THIS JOB.")
+14 DO MSG("Please contact the National Help Desk to report this issue.")
End DoDot:1
+15 QUIT
+16 ;
MSG(SDMES) ;
+1 DO BMES^XPDUTL(SDMES)
+2 QUIT
VPS ;
+1 NEW APTDT,APTIEN,RESOURCE,HOSPLOC,DFN,HLAPPT,CHKIN,STOPDT
+2 SET ^XTMP("SDEC820P",0)=$$FMADD^XLFDT(DT,30)_U_DT_U_"Logging of repaired check-in times/MRTCs."
+3 SET ^XTMP("SDEC820P","VPS","CNT")=0
+4 SET STOPDT=$$NOW^XLFDT
+5 SET APTDT=0
FOR
SET APTDT=$ORDER(^SDEC(409.84,"B",APTDT))
if 'APTDT!(APTDT>STOPDT)
QUIT
Begin DoDot:1
+6 SET APTIEN=0
FOR
SET APTIEN=$ORDER(^SDEC(409.84,"B",APTDT,APTIEN))
if 'APTIEN
QUIT
Begin DoDot:2
+7 ; B index exists, but there is no data at the IEN.
+8 if '$DATA(^SDEC(409.84,APTIEN))
QUIT
+9 ; quit if checked in
+10 IF $PIECE(^SDEC(409.84,APTIEN,0),U,3)
QUIT
+11 ; If not checked out, quit
+12 IF '$PIECE($GET(^SDEC(409.84,APTIEN,0)),U,14)
QUIT
+13 ; If cancelled, do not process
+14 IF $PIECE($GET(^SDEC(409.84,APTIEN,0)),U,12)
QUIT
+15 ; quit if no-show
+16 IF $PIECE($GET(^SDEC(409.84,APTIEN,0)),U,10)
QUIT
+17 SET RESOURCE=$PIECE(^SDEC(409.84,APTIEN,0),U,7)
if 'RESOURCE
QUIT
+18 if '$DATA(^SDEC(409.831,RESOURCE))
QUIT
+19 SET HOSPLOC=$PIECE(^SDEC(409.831,RESOURCE,0),U,4)
+20 SET DFN=$PIECE(^SDEC(409.84,APTIEN,0),U,5)
+21 SET HLAPPT=0
+22 FOR
SET HLAPPT=$ORDER(^SC(HOSPLOC,"S",APTDT,1,HLAPPT))
if 'HLAPPT
QUIT
Begin DoDot:3
+23 ; quit if not the same patient
+24 IF $PIECE($GET(^SC(HOSPLOC,"S",APTDT,1,HLAPPT,0)),U)'=DFN
QUIT
+25 ; quit if the appointment was cancelled
+26 IF $PIECE($GET(^SC(HOSPLOC,"S",APTDT,1,HLAPPT,0)),U,9)]""
QUIT
+27 ; quit if there is no check-in
+28 SET CHKIN=$PIECE($GET(^SC(HOSPLOC,"S",APTDT,1,HLAPPT,"C")),U)
if CHKIN']""
QUIT
+29 SET ^XTMP("SDEC820P","VPS",APTIEN,"BEFORE","CHECK-IN")=$PIECE($GET(^SDEC(409.84,APTIEN,0)),U,3)
+30 SET ^XTMP("SDEC820P","VPS",APTIEN,"BEFORE","CHECK-IN ENTERED")=$PIECE($GET(^SDEC(409.84,APTIEN,0)),U,4)
+31 SET $PIECE(^SDEC(409.84,APTIEN,0),U,3)=CHKIN
+32 SET $PIECE(^SDEC(409.84,APTIEN,0),U,4)=CHKIN
+33 SET ^XTMP("SDEC820P","VPS",APTIEN,"AFTER","CHECK-IN")=$PIECE($GET(^SDEC(409.84,APTIEN,0)),U,3)
+34 SET ^XTMP("SDEC820P","VPS",APTIEN,"AFTER","CHECK-IN ENTERED")=$PIECE($GET(^SDEC(409.84,APTIEN,0)),U,4)
+35 SET ^XTMP("SDEC820P","VPS",APTIEN,"SOURCE")=CHKIN
+36 SET ^XTMP("SDEC820P","VPS","CNT")=$GET(^XTMP("SDEC820P","VPS","CNT"))+1
End DoDot:3
End DoDot:2
End DoDot:1
+37 ;
+38 ; MRTC cleanup
+39 NEW REQUESTIEN,PARENTIEN,SUBIEN,MIENS,COUNT,PARENTINTERVAL,MRTCCHILDIEN
+40 SET REQUESTIEN=0
SET COUNT=0
+41 FOR
SET REQUESTIEN=$ORDER(^SDEC(409.85,REQUESTIEN))
if 'REQUESTIEN
QUIT
Begin DoDot:1
+42 ;if this record is a parent request, get the mrtc children IENs
+43 IF $PIECE($GET(^SDEC(409.85,REQUESTIEN,3)),U)=1
IF '$PIECE($GET(^SDEC(409.85,REQUESTIEN,3)),U,5)
Begin DoDot:2
End DoDot:2
+44 SET PARENTINTERVAL=$PIECE($GET(^SDEC(409.85,REQUESTIEN,3)),U,2)
+45 SET DFN=$PIECE($GET(^SDEC(409.85,REQUESTIEN,0)),U)
+46 SET SUBIEN=0
SET COUNT=0
+47 FOR
SET SUBIEN=$ORDER(^SDEC(409.85,REQUESTIEN,2,SUBIEN))
if 'SUBIEN
QUIT
Begin DoDot:2
+48 SET COUNT=COUNT+1
+49 SET MRTCCHILDIEN=$PIECE($GET(^SDEC(409.85,REQUESTIEN,2,SUBIEN,0)),U)
+50 SET ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"BEFORE","INTERVAL")=$PIECE($GET(^SDEC(409.85,MRTCCHILDIEN,3)),U,2)
+51 SET ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"BEFORE","CHILD SEQUENCE")=$PIECE($GET(^SDEC(409.85,MRTCCHILDIEN,3)),U,6)
+52 SET $PIECE(^SDEC(409.85,MRTCCHILDIEN,3),U,2)=PARENTINTERVAL
+53 SET $PIECE(^SDEC(409.85,MRTCCHILDIEN,3),U,6)=COUNT
+54 SET ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"AFTER","INTERVAL")=$PIECE($GET(^SDEC(409.85,MRTCCHILDIEN,3)),U,2)
+55 SET ^XTMP("SDEC820P","MRTC",MRTCCHILDIEN,"AFTER","CHILD SEQUENCE")=$PIECE($GET(^SDEC(409.85,MRTCCHILDIEN,3)),U,6)
End DoDot:2
End DoDot:1
+56 DO MAIL
+57 QUIT
MAIL ;
+1 ; Get Station Number
+2 ;
+3 NEW STANUM,MESS1,XMTEXT,TEXT,XMSUB,XMY,XMDUZ,DIFROM
+4 SET STANUM=$$KSP^XUPARAM("INST")_","
+5 SET STANUM=$$GET1^DIQ(4,STANUM,99)
+6 SET MESS1="Station: "_STANUM_" - "
+7 ;
+8 ; Send MailMan message
+9 SET XMDUZ=DUZ
+10 SET XMTEXT="TEXT("
+11 SET TEXT(1)="The SD*5.3*820 post install has run to completion."
+12 SET TEXT(2)="The data was reviewed and updated without any issues."
+13 SET XMSUB=MESS1_"SD*5.3*820 - Post Install Update"
+14 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMY(XMDUZ)=""
+15 DO ^XMD
+16 QUIT
ADD ;** Add DSS IDs
+1 ;
+2 ; SDXX is in format:
+3 ; STOP CODE NAME^AMIS #^RESTRICTION TYPE^REST. DATE^CDR #
+4 ;
+5 NEW SDX,SDXX
+6 SET SDVAR=1
+7 DO MES^XPDUTL("")
+8 DO BMES^XPDUTL(">>> Adding new Clinic Stops to CLINIC STOP File (#40.7)...")
+9 ;
+10 ;
+11 DO BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 9/1/2022]")
+12 SET DIC(0)="L"
SET DLAYGO=40.7
SET DIC="^DIC(40.7,"
+13 FOR SDX=1:1
KILL DD,DO,DA
SET SDXX=$PIECE($TEXT(NEW+SDX),";;",2)
if SDXX="QUIT"
QUIT
Begin DoDot:1
+14 SET DIC("DR")="1////"_$PIECE(SDXX,"^",2)
+15 SET DIC("DR")=DIC("DR")_";5////"_$PIECE(SDXX,"^",3)_";6///"_$PIECE(SDXX,"^",4)
+16 SET X=$PIECE(SDXX,"^",1)
+17 IF '$DATA(^DIC(40.7,"C",$PIECE(SDXX,"^",2)))
DO FILE^DICN
DO MESS
QUIT
+18 IF $DATA(^DIC(40.7,"C",$PIECE(SDXX,"^",2)))
DO EDIT(SDXX)
DO MESSEX
End DoDot:1
+19 KILL DIC,DLAYGO,X
+20 QUIT
+21 ;
NEW ;STOP CODE NAME^NUMBER^RESTRICTION TYPE^RESTRICTION DATE^CDR
+1 ;;REGISTRY EXAM CVT PT SITE^497^S^9/1/2022
+2 ;;REGISTRY EXAM CVT PROV SITE^498^S^9/1/2022
+3 ;;QUIT
+4 ;
MESS ;** Add message
+1 NEW ECXADMSG
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET ECXADMSG="Added: "_$PIECE(SDXX,"^",2)_" "_$PIECE(SDXX,"^")
+5 IF $PIECE(SDXX,"^",5)'=""
SET ECXADMSG=ECXADMSG_" [CDR#: "_$PIECE(SDXX,"^",5)_"]"
+6 DO MES^XPDUTL(ECXADMSG)
+7 IF $PIECE(SDXX,"^",3)'=""
SET ECXADMSG=" Restricted Type: "_$PIECE(SDXX,"^",3)_" Restricted Date: "_$PIECE(SDXX,"^",4)
+8 DO MES^XPDUTL(ECXADMSG)
+9 KILL SDVAR
+10 QUIT
+11 ;
MESSEX ;** Display message if stop code already exists
+1 NEW ECXADMSG
+2 IF +$GET(SDVAR)
DO HDR(SDVAR)
+3 DO MES^XPDUTL(" ")
+4 SET ECXADMSG=" "_$PIECE(SDXX,"^",2)_" "_$PIECE(SDXX,"^")_" already exists."
+5 DO MES^XPDUTL(ECXADMSG)
+6 KILL SDVAR
+7 QUIT
+8 ;
EDIT(SDXX) ;- Edit fields w/new values if stop code record already exists
+1 ;
+2 if $GET(SDXX)=""
QUIT
+3 NEW DA,DIE,DLAYGO,DR
+4 SET DA=+$ORDER(^DIC(40.7,"C",+$PIECE(SDXX,"^",2),0))
+5 if 'DA
QUIT
+6 SET DIE="^DIC(40.7,"
SET DR=".01///"_$PIECE(SDXX,"^")_";1///"_$PIECE(SDXX,"^",2)_";2///@"_$SELECT('+$PIECE(SDXX,U,5):"",1:";4///"_$PIECE(SDXX,"^",5))_";5///"_$PIECE(SDXX,"^",3)_";6///"_$PIECE(SDXX,"^",4)
+7 DO ^DIE
+8 QUIT
HDR(SDVAR) ;- Header
+1 if '$GET(SDVAR)
QUIT
+2 NEW SDHDR
+3 SET SDHDR=$PIECE($TEXT(@("HDR"_SDVAR)),";;",2)
+4 DO BMES^XPDUTL(SDHDR)
+5 QUIT
+6 ;
+7 ;
HDR1 ;; Stop Code Name
+1 ;
HDR2 ;; CDR Stop Code Name
+1 ;
HDR3 ;; Stop Code Name Rest. Type Date
+1 ;
+2 ;
+3 QUIT
