- PXRMP19A ;BP/WAT;post-install for patch 19 con't ;02/27/17 13:31
- ;;2.0;CLINICAL REMINDERS;**19**;Feb 04, 2005;Build 187
- Q
- ;INTEGRATION AGREEMENTS
- ;;3083 ^AUTTHF( | 10141 ^XPDUTL | 10103 ^XLFDT | 10104 ^XLFSTR | 10063 ^%ZTLOAD | 2263 ^XPAR | 1131 XMB("NETNAME")
- ;;10066 XMZ^XMA2 | 10070 ENT1^XMD | 2172 XPDID | 10113 ^XMB(3.9
- ;
- QUEUE(PXRMSG,ZTRTN,ZTDESC,PXRMITEM) ;CREATE A SPECIFIED TASK
- ;PARAMETERS: PXRMSG => STRING CONTAINING THE TEXT TO OUTPUT TO THE SCREEN
- ; ZTRTN => STRING CONTAINING THE ROUTINE TASKMAN SHOULD EXECUTE
- ; ZTDESC => STRING CONTAINING THE TASK'S DESCRIPTION
- ; PXRMITEM => REFERENCE TO THE VARIABLE STORING THE NUMBER OF THE CURRENT ITEM
- N ZTDTH,ZTIO,ZTSK,ZTSAVE
- S ZTSAVE("^TMP(""PXRM_CCHTHF"",$J,")=""
- S ZTSAVE("DUZ")=$G(DUZ)
- D BMES^XPDUTL("Queueing "_PXRMSG_"...")
- S ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,0,10)
- S ZTIO=""
- D ^%ZTLOAD
- S ZTREQ="@"
- I +$G(ZTSK)=0 D
- .I $G(PXRMPOST) D BMES^XPDUTL("Unable to queue the "_PXRMSG_"; file a Remedy ticket for assistance.")
- .E W "ERROR",!,"Unable to queue the "_PXRMSG_"; file a Remedy ticket for assistance.",!
- E D
- .I $G(PXRMPOST) D
- ..D BMES^XPDUTL("DONE - Task #"_ZTSK)
- ..D UPDATE^XPDID($G(PXRMITEM))
- ..S PXRMITEM=PXRMITEM+1
- .E W "DONE",!,"Task #"_ZTSK,!
- Q
- SEND(NODE,SUBJECT,FROM) ;Send a MailMan message whose text is in ^TMP(NODE,$J,N,0).
- N SUBSCR,NL,REF,XMDUZ,XMSUB,XMY,XMZ S SUBSCR="PXRM19RECIPS"
- I $Q(^XTMP(SUBSCR,0))[SUBSCR D
- .M XMY=^XTMP(SUBSCR)
- E S XMY(DUZ)=""
- I $D(ZTQUEUED)>0 D
- .S XMY(DUZ)=""
- S XMSUB=$E(SUBJECT,1,64)
- S XMDUZ=$G(FROM)
- ;
- RETRY ;Get the message number.
- D XMZ^XMA2
- I XMZ<1 G RETRY
- ;
- ;Load message, send
- M ^XMB(3.9,XMZ,2)=^TMP(NODE,$J)
- K ^TMP(NODE,$J)
- S NL=$O(^XMB(3.9,XMZ,2,""),-1)
- S ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
- D ENT1^XMD Q
- Q
- ;
- MAIN ; main module
- K ^TMP("PXRMPATS",$J)
- N INC,NODE,SUBJ,FROM S INC=1,NODE="PXRM_CCHTHF",SUBJ="LOCAL CCHT HFs NOT USED IN NAT'L HT CLIN REMINDER CONTENT",FROM="PXRM*2.0*19 Install@"_^XMB("NETNAME")
- D LOCHF
- D SEND(NODE,SUBJ,FROM)
- D CLNTMP
- Q
- ;
- CLNTMP ;need to check clean up of TMP arrays when done with them
- K ^TMP("PXRM19HF",$J)
- K ^TMP("PXRM_CCHTHF",$J)
- K ^XTMP("PXRM19RECIPS")
- Q
- ;
- LOCHF ;report out local CCHT HFs not used in HT reminder content
- ;build list of all HFs in the HT content
- ;build list of all local "CCHT" or "CARE COORDIATION HOME TELEHEALTH" HFs
- ;compare the two lists and report out any local HFs that are NOT used by HT
- N NODEA,NODEB,CATEGORY,INACTIVE,HFIEN,COUNT,FLAG
- S NODEA="PXRM19HF",NODEB="PXRM_CCHTHF",COUNT=3
- D HTHFTMP,HFLKUP,COMPARE(NODEA,NODEB)
- I $D(^TMP("PXRM_CCHTHF",$J))'>0 S ^TMP("PXRM_CCHTHF",$J,1,0)="No local CCHT/CARE COORDINATION health factors found." Q
- ;add category and inactive values to TMP array entries
- F S COUNT=$O(^TMP("PXRM_CCHTHF",$J,COUNT)) Q:$G(COUNT)="" D
- . S HFIEN=$P(^TMP("PXRM_CCHTHF",$J,COUNT,0),"^")
- . S:$G(HFIEN) CATEGORY=$P(^AUTTHF(HFIEN,0),"^",3)
- . S:$G(CATEGORY) CATEGORY=$P(^AUTTHF(CATEGORY,0),"^",1)
- . I $L(CATEGORY)<40 S CATEGORY=CATEGORY_$$REPEAT^XLFSTR(" ",(40-$L(CATEGORY)))
- . S FLAG=$P(^AUTTHF(HFIEN,0),"^",11)
- . S ^TMP("PXRM_CCHTHF",$J,COUNT,0)=$P(^TMP("PXRM_CCHTHF",$J,COUNT,0),U,2)
- . S ^TMP("PXRM_CCHTHF",$J,COUNT+.1,0)=$J($G(CATEGORY),47)_$J($S($G(FLAG)=1:"YES",1:"NO"),17)
- . S COUNT=$O(^TMP("PXRM_CCHTHF",$J,COUNT)) ;need this to get past the X.1 subscript set in the line above
- ;add header text
- S ^TMP("PXRM_CCHTHF",$J,1,0)="HEALTH FACTOR"
- S ^TMP("PXRM_CCHTHF",$J,2,0)=$J("CATEGORY",15)_$J("INACTIVE?",55)
- S ^TMP("PXRM_CCHTHF",$J,3,0)=$$REPEAT^XLFSTR("-",78)
- Q
- ;
- HTHFTMP ;build TMP array of HT HFs
- K ^TMP("PXRM19HF",$J)
- N PXRMI,PXRMFCTR,PXRMCNT
- S PXRMCNT=1
- F PXRMI=1:1 S PXRMFCTR=$P($T(HF+PXRMI^PXRMP19B),";",3) Q:PXRMFCTR="EOF" D
- .I PXRMFCTR="HT (CARE COORDINATION HOME TELEHEALTH)" S PXRMFCTR="HT (HOME TELEHEALTH)"
- .S ^TMP("PXRM19HF",$J,PXRMCNT)=PXRMFCTR,PXRMCNT=PXRMCNT+1
- Q
- ;
- COMPARE(PXRMA,PXRMB) ; compare list PXRMA and PXRMB. Remove duplicate items from PXRMB
- Q:'$D(^TMP(PXRMA,$J))
- Q:'$D(^TMP(PXRMB,$J))
- N ACOUNT,BCOUNT,HFA,HFB,INDEX S (ACOUNT,BCOUNT,INDEX)=0
- F S BCOUNT=$O(^TMP(PXRMB,$J,BCOUNT)) Q:BCOUNT="" D
- . S HFB=^TMP(PXRMB,$J,BCOUNT,0),HFB=$P(HFB,U,2)
- . F S ACOUNT=$O(^TMP(PXRMA,$J,ACOUNT)) Q:ACOUNT="" D
- . . S HFA=^TMP(PXRMA,$J,ACOUNT)
- . . I HFA=HFB K ^TMP(PXRMB,$J,BCOUNT) ;leave only non-matches in PXRM_CCHTHF
- Q
- ;
- HFLKUP ;find local HFs with "CCHT" or "CARE COORDINATION" in name or category
- ;^TMP("PXRM_CCHTHF",$J)=IEN OF HF ^ NAME OF HF
- K ^TMP("PXRM_CCHTHF",$J)
- N HFIEN,HFNAME,HFCAT,CNT S HFIEN=0,HFNAME="",CNT=4
- F S HFNAME=$O(^AUTTHF("B",HFNAME)) Q:HFNAME="" D
- .S HFIEN=$O(^AUTTHF("B",HFNAME,"")) Q:HFIEN'>99999
- .S HFCAT=$P(^AUTTHF(HFIEN,0),U,3) I $G(HFCAT)'="" D
- ..I $D(^AUTTHF(HFCAT))>0 S HFCAT=$P(^AUTTHF(HFCAT,0),U)
- .I (HFNAME["CCHT")!(HFNAME["CARE COORDINATION HOME TELEHEALTH")!(HFCAT["CCHT")!(HFCAT["CARE COORDINATION HOME TELEHEALTH") D
- ..S ^TMP("PXRM_CCHTHF",$J,CNT,0)=HFIEN_"^"_HFNAME_"^0",CNT=CNT+1
- Q
- ;
- ORWPCE(PXRMITEM) ;set parameter value to true
- ;;HT (HOME TELEHEALTH)
- ;;HT ASSESSMENT/TREATMENT PLAN
- ;;HT CAREGIVER RISK ASSESSMENT SCREEN
- ;;HT CONTINUUM OF CARE (CCF)
- ;;HT DISCHARGE
- ;;HT REFERRALS FOR VETERAN/CAREGIVER
- ;;HT TELEHEALTH DELIVERY/INSTALL MODE
- ;;HT TELEHEALTH DEMOGRAPHICS
- D BMES^XPDUTL("Checking ORWPCE EXCLUDE HEALTH FACTORS at the SYSTEM level")
- D MES^XPDUTL("for each HT Health Factor Category")
- N HFIEN,HFCATNAM,PXRMERR,LVL,PAR,PXRMPAR,CNT,LASTVAL
- S PAR="ORWPCE EXCLUDE HEALTH FACTORS",LVL="SYS"
- F CNT=1:1:8 D
- .D GETLST^XPAR(.PXRMPAR,LVL,PAR,"I",.PXRMERR)
- .S HFCATNAM=$P($T(ORWPCE+CNT),";;",2)
- .S HFIEN=$O(^AUTTHF("B",HFCATNAM,""))
- .D:$$CHKLIST(HFIEN,.PXRMPAR)=0&(HFIEN>0)
- ..S LASTVAL=$O(PXRMPAR(""),-1)
- ..S LASTVAL=LASTVAL+1
- ..D EN^XPAR(LVL,PAR,LASTVAL,"`"_$G(HFIEN),.PXRMERR)
- ..I +$G(PXRMERR)=0 D MES^XPDUTL("Parameter set for "_HFCATNAM)
- ..I +$G(PXRMERR)>0 D BMES^XPDUTL("ERROR: "_$P(PXRMERR,U,2))
- I $G(PXRMPOST) D
- .D UPDATE^XPDID($G(PXRMITEM))
- .S PXRMITEM=PXRMITEM+1
- Q
- ;
- TIURMDLG(PXRMITEM) ;set parameter value to true
- ;;VA-HT ASSESSMENT TREATMENT PLAN TEMPLATE
- ;;VA-HT CAREGIVER ASSESSMENT TEMPLATE
- ;;VA-HT CONTINUUM OF CARE TEMPLATE
- ;;VA-HT DISCHARGE TEMPLATE
- ;;VA-HT INTERVENTION TEMPLATE
- ;;VA-HT PERIODIC EVALUATION
- ;;VA-HT SCREENING CONSULT TEMPLATE
- ;;VA-HT TECH EDUCATION & INSTALLATION TEMPLATE
- ;;VA-HT TEMPLATE FOR PREVIOUSLY ENROLLED PATIENTS
- ;;VA-HT VIDEO VISIT TEMPLATE
- N CNT,LASTVAL,PAR,LVL,PXRMPAR,PXRMERR,DIEN,DNAME
- D BMES^XPDUTL("Checking TIU TEMPLATE REMINDER DIALOGS at the SYSTEM level")
- S PAR="TIU TEMPLATE REMINDER DIALOGS",LVL="SYS"
- F CNT=1:1:10 D
- .D GETLST^XPAR(.PXRMPAR,LVL,PAR,"I",.PXRMERR)
- .S DNAME=$P($T(TIURMDLG+CNT),";;",2)
- .S DIEN=$O(^PXRMD(801.41,"B",DNAME,"")) Q:+$G(DIEN)'>0
- .D:$$CHKLIST($G(DIEN),.PXRMPAR)=0
- ..S LASTVAL=$O(PXRMPAR(""),-1)
- ..S LASTVAL=LASTVAL+1
- ..D EN^XPAR(LVL,PAR,LASTVAL,"`"_$G(DIEN),.PXRMERR)
- ..I +$G(PXRMERR)=0 D MES^XPDUTL("Parameter set for "_DNAME)
- ..I +$G(PXRMERR)>0 D BMES^XPDUTL("ERROR: "_$P(PXRMERR,U,2))
- I $G(PXRMPOST) D
- .D UPDATE^XPDID($G(PXRMITEM))
- .S PXRMITEM=PXRMITEM+1
- Q
- ;
- CHKLIST(IEN,LIST) ;see if parameter value is already set
- N I,CHECK S CHECK=0,I=""
- Q:LIST'>0 CHECK
- F S I=$O(LIST(I)) Q:I=""!(CHECK=1) D
- .I $G(LIST(I))=IEN S CHECK=1
- Q CHECK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMP19A 7487 printed Feb 18, 2025@23:13:32 Page 2
- PXRMP19A ;BP/WAT;post-install for patch 19 con't ;02/27/17 13:31
- +1 ;;2.0;CLINICAL REMINDERS;**19**;Feb 04, 2005;Build 187
- +2 QUIT
- +3 ;INTEGRATION AGREEMENTS
- +4 ;;3083 ^AUTTHF( | 10141 ^XPDUTL | 10103 ^XLFDT | 10104 ^XLFSTR | 10063 ^%ZTLOAD | 2263 ^XPAR | 1131 XMB("NETNAME")
- +5 ;;10066 XMZ^XMA2 | 10070 ENT1^XMD | 2172 XPDID | 10113 ^XMB(3.9
- +6 ;
- QUEUE(PXRMSG,ZTRTN,ZTDESC,PXRMITEM) ;CREATE A SPECIFIED TASK
- +1 ;PARAMETERS: PXRMSG => STRING CONTAINING THE TEXT TO OUTPUT TO THE SCREEN
- +2 ; ZTRTN => STRING CONTAINING THE ROUTINE TASKMAN SHOULD EXECUTE
- +3 ; ZTDESC => STRING CONTAINING THE TASK'S DESCRIPTION
- +4 ; PXRMITEM => REFERENCE TO THE VARIABLE STORING THE NUMBER OF THE CURRENT ITEM
- +5 NEW ZTDTH,ZTIO,ZTSK,ZTSAVE
- +6 SET ZTSAVE("^TMP(""PXRM_CCHTHF"",$J,")=""
- +7 SET ZTSAVE("DUZ")=$GET(DUZ)
- +8 DO BMES^XPDUTL("Queueing "_PXRMSG_"...")
- +9 SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,0,10)
- +10 SET ZTIO=""
- +11 DO ^%ZTLOAD
- +12 SET ZTREQ="@"
- +13 IF +$GET(ZTSK)=0
- Begin DoDot:1
- +14 IF $GET(PXRMPOST)
- DO BMES^XPDUTL("Unable to queue the "_PXRMSG_"; file a Remedy ticket for assistance.")
- +15 IF '$TEST
- WRITE "ERROR",!,"Unable to queue the "_PXRMSG_"; file a Remedy ticket for assistance.",!
- End DoDot:1
- +16 IF '$TEST
- Begin DoDot:1
- +17 IF $GET(PXRMPOST)
- Begin DoDot:2
- +18 DO BMES^XPDUTL("DONE - Task #"_ZTSK)
- +19 DO UPDATE^XPDID($GET(PXRMITEM))
- +20 SET PXRMITEM=PXRMITEM+1
- End DoDot:2
- +21 IF '$TEST
- WRITE "DONE",!,"Task #"_ZTSK,!
- End DoDot:1
- +22 QUIT
- SEND(NODE,SUBJECT,FROM) ;Send a MailMan message whose text is in ^TMP(NODE,$J,N,0).
- +1 NEW SUBSCR,NL,REF,XMDUZ,XMSUB,XMY,XMZ
- SET SUBSCR="PXRM19RECIPS"
- +2 IF $QUERY(^XTMP(SUBSCR,0))[SUBSCR
- Begin DoDot:1
- +3 MERGE XMY=^XTMP(SUBSCR)
- End DoDot:1
- +4 IF '$TEST
- SET XMY(DUZ)=""
- +5 IF $DATA(ZTQUEUED)>0
- Begin DoDot:1
- +6 SET XMY(DUZ)=""
- End DoDot:1
- +7 SET XMSUB=$EXTRACT(SUBJECT,1,64)
- +8 SET XMDUZ=$GET(FROM)
- +9 ;
- RETRY ;Get the message number.
- +1 DO XMZ^XMA2
- +2 IF XMZ<1
- GOTO RETRY
- +3 ;
- +4 ;Load message, send
- +5 MERGE ^XMB(3.9,XMZ,2)=^TMP(NODE,$JOB)
- +6 KILL ^TMP(NODE,$JOB)
- +7 SET NL=$ORDER(^XMB(3.9,XMZ,2,""),-1)
- +8 SET ^XMB(3.9,XMZ,2,0)="^3.92^"_+NL_U_+NL_U_DT
- +9 DO ENT1^XMD
- QUIT
- +10 QUIT
- +11 ;
- MAIN ; main module
- +1 KILL ^TMP("PXRMPATS",$JOB)
- +2 NEW INC,NODE,SUBJ,FROM
- SET INC=1
- SET NODE="PXRM_CCHTHF"
- SET SUBJ="LOCAL CCHT HFs NOT USED IN NAT'L HT CLIN REMINDER CONTENT"
- SET FROM="PXRM*2.0*19 Install@"_^XMB("NETNAME")
- +3 DO LOCHF
- +4 DO SEND(NODE,SUBJ,FROM)
- +5 DO CLNTMP
- +6 QUIT
- +7 ;
- CLNTMP ;need to check clean up of TMP arrays when done with them
- +1 KILL ^TMP("PXRM19HF",$JOB)
- +2 KILL ^TMP("PXRM_CCHTHF",$JOB)
- +3 KILL ^XTMP("PXRM19RECIPS")
- +4 QUIT
- +5 ;
- LOCHF ;report out local CCHT HFs not used in HT reminder content
- +1 ;build list of all HFs in the HT content
- +2 ;build list of all local "CCHT" or "CARE COORDIATION HOME TELEHEALTH" HFs
- +3 ;compare the two lists and report out any local HFs that are NOT used by HT
- +4 NEW NODEA,NODEB,CATEGORY,INACTIVE,HFIEN,COUNT,FLAG
- +5 SET NODEA="PXRM19HF"
- SET NODEB="PXRM_CCHTHF"
- SET COUNT=3
- +6 DO HTHFTMP
- DO HFLKUP
- DO COMPARE(NODEA,NODEB)
- +7 IF $DATA(^TMP("PXRM_CCHTHF",$JOB))'>0
- SET ^TMP("PXRM_CCHTHF",$JOB,1,0)="No local CCHT/CARE COORDINATION health factors found."
- QUIT
- +8 ;add category and inactive values to TMP array entries
- +9 FOR
- SET COUNT=$ORDER(^TMP("PXRM_CCHTHF",$JOB,COUNT))
- if $GET(COUNT)=""
- QUIT
- Begin DoDot:1
- +10 SET HFIEN=$PIECE(^TMP("PXRM_CCHTHF",$JOB,COUNT,0),"^")
- +11 if $GET(HFIEN)
- SET CATEGORY=$PIECE(^AUTTHF(HFIEN,0),"^",3)
- +12 if $GET(CATEGORY)
- SET CATEGORY=$PIECE(^AUTTHF(CATEGORY,0),"^",1)
- +13 IF $LENGTH(CATEGORY)<40
- SET CATEGORY=CATEGORY_$$REPEAT^XLFSTR(" ",(40-$LENGTH(CATEGORY)))
- +14 SET FLAG=$PIECE(^AUTTHF(HFIEN,0),"^",11)
- +15 SET ^TMP("PXRM_CCHTHF",$JOB,COUNT,0)=$PIECE(^TMP("PXRM_CCHTHF",$JOB,COUNT,0),U,2)
- +16 SET ^TMP("PXRM_CCHTHF",$JOB,COUNT+.1,0)=$JUSTIFY($GET(CATEGORY),47)_$JUSTIFY($SELECT($GET(FLAG)=1:"YES",1:"NO"),17)
- +17 ;need this to get past the X.1 subscript set in the line above
- SET COUNT=$ORDER(^TMP("PXRM_CCHTHF",$JOB,COUNT))
- End DoDot:1
- +18 ;add header text
- +19 SET ^TMP("PXRM_CCHTHF",$JOB,1,0)="HEALTH FACTOR"
- +20 SET ^TMP("PXRM_CCHTHF",$JOB,2,0)=$JUSTIFY("CATEGORY",15)_$JUSTIFY("INACTIVE?",55)
- +21 SET ^TMP("PXRM_CCHTHF",$JOB,3,0)=$$REPEAT^XLFSTR("-",78)
- +22 QUIT
- +23 ;
- HTHFTMP ;build TMP array of HT HFs
- +1 KILL ^TMP("PXRM19HF",$JOB)
- +2 NEW PXRMI,PXRMFCTR,PXRMCNT
- +3 SET PXRMCNT=1
- +4 FOR PXRMI=1:1
- SET PXRMFCTR=$PIECE($TEXT(HF+PXRMI^PXRMP19B),";",3)
- if PXRMFCTR="EOF"
- QUIT
- Begin DoDot:1
- +5 IF PXRMFCTR="HT (CARE COORDINATION HOME TELEHEALTH)"
- SET PXRMFCTR="HT (HOME TELEHEALTH)"
- +6 SET ^TMP("PXRM19HF",$JOB,PXRMCNT)=PXRMFCTR
- SET PXRMCNT=PXRMCNT+1
- End DoDot:1
- +7 QUIT
- +8 ;
- COMPARE(PXRMA,PXRMB) ; compare list PXRMA and PXRMB. Remove duplicate items from PXRMB
- +1 if '$DATA(^TMP(PXRMA,$JOB))
- QUIT
- +2 if '$DATA(^TMP(PXRMB,$JOB))
- QUIT
- +3 NEW ACOUNT,BCOUNT,HFA,HFB,INDEX
- SET (ACOUNT,BCOUNT,INDEX)=0
- +4 FOR
- SET BCOUNT=$ORDER(^TMP(PXRMB,$JOB,BCOUNT))
- if BCOUNT=""
- QUIT
- Begin DoDot:1
- +5 SET HFB=^TMP(PXRMB,$JOB,BCOUNT,0)
- SET HFB=$PIECE(HFB,U,2)
- +6 FOR
- SET ACOUNT=$ORDER(^TMP(PXRMA,$JOB,ACOUNT))
- if ACOUNT=""
- QUIT
- Begin DoDot:2
- +7 SET HFA=^TMP(PXRMA,$JOB,ACOUNT)
- +8 ;leave only non-matches in PXRM_CCHTHF
- IF HFA=HFB
- KILL ^TMP(PXRMB,$JOB,BCOUNT)
- End DoDot:2
- End DoDot:1
- +9 QUIT
- +10 ;
- HFLKUP ;find local HFs with "CCHT" or "CARE COORDINATION" in name or category
- +1 ;^TMP("PXRM_CCHTHF",$J)=IEN OF HF ^ NAME OF HF
- +2 KILL ^TMP("PXRM_CCHTHF",$JOB)
- +3 NEW HFIEN,HFNAME,HFCAT,CNT
- SET HFIEN=0
- SET HFNAME=""
- SET CNT=4
- +4 FOR
- SET HFNAME=$ORDER(^AUTTHF("B",HFNAME))
- if HFNAME=""
- QUIT
- Begin DoDot:1
- +5 SET HFIEN=$ORDER(^AUTTHF("B",HFNAME,""))
- if HFIEN'>99999
- QUIT
- +6 SET HFCAT=$PIECE(^AUTTHF(HFIEN,0),U,3)
- IF $GET(HFCAT)'=""
- Begin DoDot:2
- +7 IF $DATA(^AUTTHF(HFCAT))>0
- SET HFCAT=$PIECE(^AUTTHF(HFCAT,0),U)
- End DoDot:2
- +8 IF (HFNAME["CCHT")!(HFNAME["CARE COORDINATION HOME TELEHEALTH")!(HFCAT["CCHT")!(HFCAT["CARE COORDINATION HOME TELEHEALTH")
- Begin DoDot:2
- +9 SET ^TMP("PXRM_CCHTHF",$JOB,CNT,0)=HFIEN_"^"_HFNAME_"^0"
- SET CNT=CNT+1
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- ORWPCE(PXRMITEM) ;set parameter value to true
- +1 ;;HT (HOME TELEHEALTH)
- +2 ;;HT ASSESSMENT/TREATMENT PLAN
- +3 ;;HT CAREGIVER RISK ASSESSMENT SCREEN
- +4 ;;HT CONTINUUM OF CARE (CCF)
- +5 ;;HT DISCHARGE
- +6 ;;HT REFERRALS FOR VETERAN/CAREGIVER
- +7 ;;HT TELEHEALTH DELIVERY/INSTALL MODE
- +8 ;;HT TELEHEALTH DEMOGRAPHICS
- +9 DO BMES^XPDUTL("Checking ORWPCE EXCLUDE HEALTH FACTORS at the SYSTEM level")
- +10 DO MES^XPDUTL("for each HT Health Factor Category")
- +11 NEW HFIEN,HFCATNAM,PXRMERR,LVL,PAR,PXRMPAR,CNT,LASTVAL
- +12 SET PAR="ORWPCE EXCLUDE HEALTH FACTORS"
- SET LVL="SYS"
- +13 FOR CNT=1:1:8
- Begin DoDot:1
- +14 DO GETLST^XPAR(.PXRMPAR,LVL,PAR,"I",.PXRMERR)
- +15 SET HFCATNAM=$PIECE($TEXT(ORWPCE+CNT),";;",2)
- +16 SET HFIEN=$ORDER(^AUTTHF("B",HFCATNAM,""))
- +17 if $$CHKLIST(HFIEN,.PXRMPAR)=0&(HFIEN>0)
- Begin DoDot:2
- +18 SET LASTVAL=$ORDER(PXRMPAR(""),-1)
- +19 SET LASTVAL=LASTVAL+1
- +20 DO EN^XPAR(LVL,PAR,LASTVAL,"`"_$GET(HFIEN),.PXRMERR)
- +21 IF +$GET(PXRMERR)=0
- DO MES^XPDUTL("Parameter set for "_HFCATNAM)
- +22 IF +$GET(PXRMERR)>0
- DO BMES^XPDUTL("ERROR: "_$PIECE(PXRMERR,U,2))
- End DoDot:2
- End DoDot:1
- +23 IF $GET(PXRMPOST)
- Begin DoDot:1
- +24 DO UPDATE^XPDID($GET(PXRMITEM))
- +25 SET PXRMITEM=PXRMITEM+1
- End DoDot:1
- +26 QUIT
- +27 ;
- TIURMDLG(PXRMITEM) ;set parameter value to true
- +1 ;;VA-HT ASSESSMENT TREATMENT PLAN TEMPLATE
- +2 ;;VA-HT CAREGIVER ASSESSMENT TEMPLATE
- +3 ;;VA-HT CONTINUUM OF CARE TEMPLATE
- +4 ;;VA-HT DISCHARGE TEMPLATE
- +5 ;;VA-HT INTERVENTION TEMPLATE
- +6 ;;VA-HT PERIODIC EVALUATION
- +7 ;;VA-HT SCREENING CONSULT TEMPLATE
- +8 ;;VA-HT TECH EDUCATION & INSTALLATION TEMPLATE
- +9 ;;VA-HT TEMPLATE FOR PREVIOUSLY ENROLLED PATIENTS
- +10 ;;VA-HT VIDEO VISIT TEMPLATE
- +11 NEW CNT,LASTVAL,PAR,LVL,PXRMPAR,PXRMERR,DIEN,DNAME
- +12 DO BMES^XPDUTL("Checking TIU TEMPLATE REMINDER DIALOGS at the SYSTEM level")
- +13 SET PAR="TIU TEMPLATE REMINDER DIALOGS"
- SET LVL="SYS"
- +14 FOR CNT=1:1:10
- Begin DoDot:1
- +15 DO GETLST^XPAR(.PXRMPAR,LVL,PAR,"I",.PXRMERR)
- +16 SET DNAME=$PIECE($TEXT(TIURMDLG+CNT),";;",2)
- +17 SET DIEN=$ORDER(^PXRMD(801.41,"B",DNAME,""))
- if +$GET(DIEN)'>0
- QUIT
- +18 if $$CHKLIST($GET(DIEN),.PXRMPAR)=0
- Begin DoDot:2
- +19 SET LASTVAL=$ORDER(PXRMPAR(""),-1)
- +20 SET LASTVAL=LASTVAL+1
- +21 DO EN^XPAR(LVL,PAR,LASTVAL,"`"_$GET(DIEN),.PXRMERR)
- +22 IF +$GET(PXRMERR)=0
- DO MES^XPDUTL("Parameter set for "_DNAME)
- +23 IF +$GET(PXRMERR)>0
- DO BMES^XPDUTL("ERROR: "_$PIECE(PXRMERR,U,2))
- End DoDot:2
- End DoDot:1
- +24 IF $GET(PXRMPOST)
- Begin DoDot:1
- +25 DO UPDATE^XPDID($GET(PXRMITEM))
- +26 SET PXRMITEM=PXRMITEM+1
- End DoDot:1
- +27 QUIT
- +28 ;
- CHKLIST(IEN,LIST) ;see if parameter value is already set
- +1 NEW I,CHECK
- SET CHECK=0
- SET I=""
- +2 if LIST'>0
- QUIT CHECK
- +3 FOR
- SET I=$ORDER(LIST(I))
- if I=""!(CHECK=1)
- QUIT
- Begin DoDot:1
- +4 IF $GET(LIST(I))=IEN
- SET CHECK=1
- End DoDot:1
- +5 QUIT CHECK