Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC14.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC14.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC14.m (revision 623) @@ -1,90 +1,87 @@ -SCAPMC14 ;ALB/REW - Team API's: PTPR ; JUN 30, 1995 - ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26 - ;;1.0 -PTPR(SC200,SCDATES,SCPURPA,SCROLEA,SCLIST,SCERR,SCYESCL) ; -- list patients for a pract (scyescl NOT supported) - ; input: - ; SC200 = ien of NEW PERSON file(#200) [required] - ; SCDATES("BEGIN") = begin date to search (inclusive) - ; [default: TODAY] - ; ("END") = end date to search (inclusive) - ; [default: TODAY] - ; ("INCL") = 1: only use patients who were assigned to - ; team for entire date range - ; 0: anytime in date range - ; [default: 1] - ; SCPURPA -array of pointers to team purpose file 403.47 - ; if none are defined - returns all teams - ; if @SCPURPA@('exclude') is defined - exclude listed teams - ; SCROLEA-array of pointer to 403.46 (per SCPURPA) - ; SCLIST -array name to store list - ; [ex. ^TMP("SCPT",$J)] - ; - ; SCERR = array NAME to store error messages. - ; [ex. ^TMP("ORXX",$J)] - ; SCYESCL = Boolean to indicate 1=use associated clinics 0=don't - ; default=0 - ; - ; - ; Output: - ; SCLIST() = array of patients - ; Format: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of PATIENT file entry - ; 2 Name of patient - ; 3 IEN of Pt Team Posit Asment if position=source - ; 4 Activation Date - ; 5 Inactivation Date - ; 6 Source 1=Clinic, Null=Position - ; 7 IEN of Clinic if clinic=source - ; - ; SCERR() = Array of DIALOG file messages(errors) . - ; @SCERR@(0) = number of errors, undefined if none - ; Format: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of DIALOG file - ; Returned: 1 if ok, 0 if error - ; - ; -ST N SCTM,SCPTA,SCPTA0,SCOK,SCX,NODE,TPACT,TPINACT,SCTEMP,SCTP,SCUSR - N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS - ; -- initialize control variables - G:'$$OKDATA PRACQ - ; -- get list of positions for practitioner - G:'$$TPPR^SCAPMC(SC200,SCDATES,.SCPURPA,.SCROLEA,"SCTEMP",.SCERR) PRACQ - G:'$G(SCTEMP(0)) PRACQ - S SCTP=0 - ;get list of patients for each position - F SCX=1:1 S NODE=$G(SCTEMP(SCX)),SCTP=+NODE Q:'SCTP D Q:'SCOK - .S TPACT=$P(SCTEMP(SCX),U,5) - .S TPINACT=$P(SCTEMP(SCX),U,6) - .N SCDTPR - .S SCDTPR("BEGIN")=$S(TPACT>@SCDATES@("BEGIN"):TPACT,1:@SCDATES@("BEGIN")) - .S SCDTPR("END")=$S('TPINACT:@SCDATES@("END"),(TPINACT<@SCDATES@("END")):TPINACT,1:@SCDATES@("END")) - .S SCDTPR("INCL")=@SCDATES@("INCL") - .S SCOK=$$PTTP^SCAPMC(SCTP,"SCDTPR",.SCLIST,.SCERR) - .Q:'SCOK - .Q:'SCYESCL - .;S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9) - .;Q:'SC44 - .N CNAME,SC44 - .D SETASCL^SCRPRAC2(SCTP,.CNAME,.SC44) - .N SCCNT S SCCNT=0 - .F S SCCNT=$O(SC44(SCCNT)) Q:SCCNT="" S SCOK=$$PTCL^SCAPMC(SC44(SCCNT),"SCDTPR",.SCLIST,.SCERR) -PRACQ Q $G(@SCERR@(0))<1 - ; -OKDATA() ;setup/check variables - N SCOK - S SCOK=1 - S SCYESCL=$G(SCYESCL,0) - D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) - IF '$D(^VA(200,+$G(SC200),0)) D S SCOK=0 - . S SCPARM("PRACT")=$G(SC200,"Undefined") - . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) - ; -- is it a valid DFN passed (Error # 20001 in DIALOG file) - IF '$D(^VA(200,+SC200,0)) D S SCOK=0 - . S SCPARM("PRACT")=SC200 - . D ERR^SCAPMCU1(SCESEQ,20001,.SCPARM,"",.SCERR) - Q SCOK - ; +SCAPMC14 ;ALB/REW - Team API's: PTPR ; JUN 30, 1995 + ;;5.3;Scheduling;**41**;AUG 13, 1993 + ;;1.0 +PTPR(SC200,SCDATES,SCPURPA,SCROLEA,SCLIST,SCERR,SCYESCL) ; -- list patients for a pract (scyescl NOT supported) + ; input: + ; SC200 = ien of NEW PERSON file(#200) [required] + ; SCDATES("BEGIN") = begin date to search (inclusive) + ; [default: TODAY] + ; ("END") = end date to search (inclusive) + ; [default: TODAY] + ; ("INCL") = 1: only use patients who were assigned to + ; team for entire date range + ; 0: anytime in date range + ; [default: 1] + ; SCPURPA -array of pointers to team purpose file 403.47 + ; if none are defined - returns all teams + ; if @SCPURPA@('exclude') is defined - exclude listed teams + ; SCROLEA-array of pointer to 403.46 (per SCPURPA) + ; SCLIST -array name to store list + ; [ex. ^TMP("SCPT",$J)] + ; + ; SCERR = array NAME to store error messages. + ; [ex. ^TMP("ORXX",$J)] + ; SCYESCL = Boolean to indicate 1=use associated clinics 0=don't + ; default=0 + ; + ; + ; Output: + ; SCLIST() = array of patients + ; Format: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of PATIENT file entry + ; 2 Name of patient + ; 3 IEN of Pt Team Posit Asment if position=source + ; 4 Activation Date + ; 5 Inactivation Date + ; 6 Source 1=Clinic, Null=Position + ; 7 IEN of Clinic if clinic=source + ; + ; SCERR() = Array of DIALOG file messages(errors) . + ; @SCERR@(0) = number of errors, undefined if none + ; Format: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of DIALOG file + ; Returned: 1 if ok, 0 if error + ; + ; +ST N SCTM,SCPTA,SCPTA0,SCOK,SCX,NODE,TPACT,TPINACT,SCTEMP,SCTP,SCUSR + N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS + ; -- initialize control variables + G:'$$OKDATA PRACQ + ; -- get list of positions for practitioner + G:'$$TPPR^SCAPMC(SC200,SCDATES,.SCPURPA,.SCROLEA,"SCTEMP",.SCERR) PRACQ + G:'$G(SCTEMP(0)) PRACQ + S SCTP=0 + ;get list of patients for each position + F SCX=1:1 S NODE=$G(SCTEMP(SCX)),SCTP=+NODE Q:'SCTP D Q:'SCOK + .S TPACT=$P(SCTEMP(SCX),U,5) + .S TPINACT=$P(SCTEMP(SCX),U,6) + .N SCDTPR + .S SCDTPR("BEGIN")=$S(TPACT>@SCDATES@("BEGIN"):TPACT,1:@SCDATES@("BEGIN")) + .S SCDTPR("END")=$S('TPINACT:@SCDATES@("END"),(TPINACT<@SCDATES@("END")):TPINACT,1:@SCDATES@("END")) + .S SCDTPR("INCL")=@SCDATES@("INCL") + .S SCOK=$$PTTP^SCAPMC(SCTP,"SCDTPR",.SCLIST,.SCERR) + .Q:'SCOK + .Q:'SCYESCL + .S SC44=$P($G(^SCTM(404.57,+SCTP,0)),U,9) + .Q:'SC44 + .S SCOK=$$PTCL^SCAPMC(SC44,"SCDTPR",.SCLIST,.SCERR) +PRACQ Q $G(@SCERR@(0))<1 + ; +OKDATA() ;setup/check variables + N SCOK + S SCOK=1 + S SCYESCL=$G(SCYESCL,0) + D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) + IF '$D(^VA(200,+$G(SC200),0)) D S SCOK=0 + . S SCPARM("PRACT")=$G(SC200,"Undefined") + . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) + ; -- is it a valid DFN passed (Error # 20001 in DIALOG file) + IF '$D(^VA(200,+SC200,0)) D S SCOK=0 + . S SCPARM("PRACT")=SC200 + . D ERR^SCAPMCU1(SCESEQ,20001,.SCPARM,"",.SCERR) + Q SCOK + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC29.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC29.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC29.m (revision 623) @@ -1,87 +1,87 @@ -SCAPMC29 ;ALB/REW - TEAM APIs:CLPT ; 2/17/00 1:33pm - ;;5.3;Scheduling;**41,210,520**;AUG 13, 1993;Build 26 - ;;1.0 -CLPT(DFN,SCDATES,SCTEAMA,SCLIST,SCERR) ;clinics for patient - ; input: - ; DFN = ien of PATIENT [required] - ; SCDATES("BEGIN") = begin date to search (inclusive) - ; [default: TODAY] - ; ("END") = end date to search (inclusive) - ; [default: TODAY] - ; ("INCL") = 1: only use pracitioners who were on - ; team for entire date range - ; 0: anytime in date range - ; [default: 1] - ; SCTEAMA= array of teams to include reverse with scposa('exclude') - ; SCERR = array NAME to store error messages. - ; [ex. ^TMP("ORXX",$J)] - ; - ; Output: - ; SCLIST() = array of clinics - ; Format: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of HOSPITAL LOCATION file entry (#44) - ; 2 Name of CLINIC - ; 3 ENROLLMENT DATE - ; 4 DISCHARGE DATE - ; 5 OPT OR AC - ; 6 REVIEW DATE - ; - ; SCERR() = Array of DIALOG file messages(errors) . - ; @SCERR(0)= Number of error(s), UNDEFINED if no errors - ; Foramt: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of DIALOG file - ; Returned: 1 if ok, 0 if error - ; - ; -- initialize control variables - ; -ST N SCX,SCS,SC44,SCACOPT,SCTM,SCPOSA,SCTP - N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS,SCOK,SCS,SCND,SCACT,SCINACT,SCREVDT,SCCLNM - G:'$$OKDATA PTCLQ ; check/setup variables - IF $L($G(SCTEAMA)) D - .S SCTM=0 - .F S SCTM=$O(@SCTEAMA@(SCTM)) Q:'SCTM D Q:'SCX - ..S SCX=$$TPTM^SCAPMC(SCTM,SCDATES,,,"SCPOSAX",.SCERR) - .F SCX=1:1 S SCTP=+$G(SCPOSAX(SCX)) Q:'SCTP S SCPOSA(SCTP)="" - .S:$D(@SCTEAMA@("EXCLUDE")) SCPOSA("EXCLUDE")="" - ;S SCX=0 F S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX D - ;.S SC44=+$G(^DPT(DFN,"DE",SCX,0)) - ;.Q:'SC44 - ;.Q:'$$OKCLIN(SC44,.SCPOSA) - ;.S SCCLNM=$P($G(^SC(SC44,0)),U,1) - ;.S SCS=0 F S SCS=$O(^DPT(DFN,"DE",SCX,1,SCS)) Q:'SCS D - ;..S SCND=$G(^DPT(DFN,"DE",SCX,1,SCS,0)) - ;..S SCACT=$P(SCND,U,1) - ;..S SCINACT=$P(SCND,U,3) - ;..Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT,SCINACT) - ;..S SCACOPT=$P(SCND,U,2) - ;..S SCREVDT=$P(SCND,U,5) - ;..S SCN=$G(@SCLIST@(0),0)+1 - ;..;bp/ar nois brx-1298-12323 prevent undefined variable error - ;..;New code begins - ;..Q:'SCACT - ;..Q:'SCN - ;.;End of brx-1298-12323 - ;..S @SCLIST@(0)=SCN - ;..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT - ;..S @SCLIST@("SCCL",SC44,SCACT,SCN)="" -PTCLQ Q $G(@SCERR@(0))<1 - ; -OKCLIN(SC44,SCPOSA) ;is clinic ok, given position array - N SCOK,SCTP - IF '$D(SCPOSA) S SCOK=1 G QTOKC - S (SCOK,SCTP)=0 - F S SCTP=$O(^SCTM(404.57,"E",+SC44,SCTP)) Q:'SCTP S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1 -QTOKC Q SCOK - ; -OKDATA() ;check/setup variables - return 1 if ok; 0 if error - N SCOK - S SCOK=1 - D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) - IF '$D(^DPT(+$G(DFN),0)) D S SCOK=0 - . S SCPARM("PATIENT")=$G(DFN,"Undefined") - . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) - Q SCOK +SCAPMC29 ;ALB/REW - TEAM APIs:CLPT ; 2/17/00 1:33pm + ;;5.3;Scheduling;**41,210**;AUG 13, 1993 + ;;1.0 +CLPT(DFN,SCDATES,SCTEAMA,SCLIST,SCERR) ;clinics for patient + ; input: + ; DFN = ien of PATIENT [required] + ; SCDATES("BEGIN") = begin date to search (inclusive) + ; [default: TODAY] + ; ("END") = end date to search (inclusive) + ; [default: TODAY] + ; ("INCL") = 1: only use pracitioners who were on + ; team for entire date range + ; 0: anytime in date range + ; [default: 1] + ; SCTEAMA= array of teams to include reverse with scposa('exclude') + ; SCERR = array NAME to store error messages. + ; [ex. ^TMP("ORXX",$J)] + ; + ; Output: + ; SCLIST() = array of clinics + ; Format: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of HOSPITAL LOCATION file entry (#44) + ; 2 Name of CLINIC + ; 3 ENROLLMENT DATE + ; 4 DISCHARGE DATE + ; 5 OPT OR AC + ; 6 REVIEW DATE + ; + ; SCERR() = Array of DIALOG file messages(errors) . + ; @SCERR(0)= Number of error(s), UNDEFINED if no errors + ; Foramt: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of DIALOG file + ; Returned: 1 if ok, 0 if error + ; + ; -- initialize control variables + ; +ST N SCX,SCS,SC44,SCACOPT,SCTM,SCPOSA,SCTP + N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS,SCOK,SCS,SCND,SCACT,SCINACT,SCREVDT,SCCLNM + G:'$$OKDATA PTCLQ ; check/setup variables + IF $L($G(SCTEAMA)) D + .S SCTM=0 + .F S SCTM=$O(@SCTEAMA@(SCTM)) Q:'SCTM D Q:'SCX + ..S SCX=$$TPTM^SCAPMC(SCTM,SCDATES,,,"SCPOSAX",.SCERR) + .F SCX=1:1 S SCTP=+$G(SCPOSAX(SCX)) Q:'SCTP S SCPOSA(SCTP)="" + .S:$D(@SCTEAMA@("EXCLUDE")) SCPOSA("EXCLUDE")="" + S SCX=0 F S SCX=$O(^DPT(DFN,"DE",SCX)) Q:'SCX D + .S SC44=+$G(^DPT(DFN,"DE",SCX,0)) + .Q:'SC44 + .Q:'$$OKCLIN(SC44,.SCPOSA) + .S SCCLNM=$P($G(^SC(SC44,0)),U,1) + .S SCS=0 F S SCS=$O(^DPT(DFN,"DE",SCX,1,SCS)) Q:'SCS D + ..S SCND=$G(^DPT(DFN,"DE",SCX,1,SCS,0)) + ..S SCACT=$P(SCND,U,1) + ..S SCINACT=$P(SCND,U,3) + ..Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT,SCINACT) + ..S SCACOPT=$P(SCND,U,2) + ..S SCREVDT=$P(SCND,U,5) + ..S SCN=$G(@SCLIST@(0),0)+1 + ..;bp/ar nois brx-1298-12323 prevent undefined variable error + ..;New code begins + ..Q:'SCACT + ..Q:'SCN + ..;End of brx-1298-12323 + ..S @SCLIST@(0)=SCN + ..S @SCLIST@(SCN)=SC44_U_SCCLNM_U_SCACT_U_SCINACT_U_SCACOPT_U_SCREVDT + ..S @SCLIST@("SCCL",SC44,SCACT,SCN)="" +PTCLQ Q $G(@SCERR@(0))<1 + ; +OKCLIN(SC44,SCPOSA) ;is clinic ok, given position array + N SCOK,SCTP + IF '$D(SCPOSA) S SCOK=1 G QTOKC + S (SCOK,SCTP)=0 + F S SCTP=$O(^SCTM(404.57,"D",+SC44,SCTP)) Q:'SCTP S:$$OKARRAY^SCAPU1(.SCPOSA,SCTP) SCOK=1 +QTOKC Q SCOK + ; +OKDATA() ;check/setup variables - return 1 if ok; 0 if error + N SCOK + S SCOK=1 + D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) + IF '$D(^DPT(+$G(DFN),0)) D S SCOK=0 + . S SCPARM("PATIENT")=$G(DFN,"Undefined") + . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) + Q SCOK Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC30.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC30.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC30.m (revision 623) @@ -1,83 +1,83 @@ -SCAPMC30 ;ALB/REW - TEAM APIs:TPCL ; 30 Jun 95 - ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26 - ;;1.0 -TPCL(SC44,SCDATES,SCPOSA,SCUSRA,SCPURPA,SCROLEA,SCLIST,SCERR) ; -- list of positions for a clinic - ; input: - ; SC44 = ien of HOSPITAL LOCATION [required] - ; SCDATES("BEGIN") = begin date to search (inclusive) - ; [default: TODAY] - ; ("END") = end date to search (inclusive) - ; [default: TODAY] - ; ("INCL") = 1: only use patients who were assigned to - ; team for entire date range - ; 0: anytime in date range - ; [default: 1] - ; SCPOSA -array of pointers to team position - 404.57 (per SCPURPA) - ; SCUSRA -array of pointers to user file - 8930 (per SCPURPA array) - ; SCPURPA -array of pointers to team purpose file 403.47 - ; if none are defined - returns all teams - ; if @SCPURPA@('exclude') is defined - exclude listed teams - ; SCROLEA - array of pointers to std position file 403.46 (per SCPURPA) - ; SCLIST -array name to store list - ; [ex. ^TMP("SCPT",$J)] - ; - ; SCERR = array NAME to store error messages. - ; [ex. ^TMP("ORXX",$J)] - ; - ; Output: - ; SCLIST() = array of positions (includes SCTP xref) - ; Format: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of TEAM POSITION File (#404.57) - ; 2 Name of Position - ; 3 IEN of Team #404.51 - ; 4 IEN of file #404.59 (Tm Pos History) - ; 5 current effective date - ; 6 current inactivate date (if any) - ; 7 pointer to 403.46 (role) - ; 8 Name of Standard Role - ; 9 pointer to User Class (#8930) - ; 10 Name of User Class - ; Subscript: "SCTP",SCTM,IEN ="" - ; - ; SCERR() = Array of DIALOG file messages(errors) . - ; @SCERR@(0) = number of errors, undefined if none - ; Format: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of DIALOG file - ; Returned: 1 if ok, 0 if error - ; Other: - ; SCACTHIS = status (-1:err|0:inact|1:act)^404.52 ien ^actdt^inacdt - ; - ; -ST N SCPTTP,SCPTTP0,SCTP,SCR,SCACTHIS,SCTM,SCND,SCU,SCOK,SCP,SCTPCL - N SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS - ; -- initialize control variables - S SCOK=1 - G:'$$OKDATA CLTPQ - S SCTP=0 F S SCTP=$O(^SCTM(404.57,"E",SC44,SCTP)) Q:'SCTP D Q:'SCOK - .S SCTP0=$G(^SCTM(404.57,SCTP,0)) - .IF '$L(SCTP0) D - ..S SCPARM("POSITION")=$G(SCTP,"Undefined") - ..S SCPARM("CLINIC")=$G(SC44,"Undefined") - ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) - .S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2) - .S SCP=$P(^SCTM(404.51,+SCTM,0),U,3) - .Q:'$$OKARRAY^SCAPU1(.SCPURPA,.SCP) - .S SCR=+$P(^SCTM(404.57,SCTP,0),U,3) - .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR) - .S SCACTHIS=$$ACTHIST^SCAPMCU2(404.59,SCTP,SCDATES,SCERR,"SCTPCL") - .Q:'SCACTHIS - .D BLD^SCAPMC24(.SCLIST,SCTM,SCTP,SCACTHIS,SCR) -CLTPQ Q $G(@SCERR@(0))<1 - ; -OKDATA() ;check/setup variables - return 1 if ok; 0 if error - N SCOK - S SCOK=1 - D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) - IF '$D(^SC(+$G(SC44),0)) D S SCOK=0 - . S SCPARM("CLINIC")=$G(SC44,"Undefined") - . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) - Q SCOK +SCAPMC30 ;ALB/REW - TEAM APIs:TPCL ; 30 Jun 95 + ;;5.3;Scheduling;**41**;AUG 13, 1993 + ;;1.0 +TPCL(SC44,SCDATES,SCPOSA,SCUSRA,SCPURPA,SCROLEA,SCLIST,SCERR) ; -- list of positions for a clinic + ; input: + ; SC44 = ien of HOSPITAL LOCATION [required] + ; SCDATES("BEGIN") = begin date to search (inclusive) + ; [default: TODAY] + ; ("END") = end date to search (inclusive) + ; [default: TODAY] + ; ("INCL") = 1: only use patients who were assigned to + ; team for entire date range + ; 0: anytime in date range + ; [default: 1] + ; SCPOSA -array of pointers to team position - 404.57 (per SCPURPA) + ; SCUSRA -array of pointers to user file - 8930 (per SCPURPA array) + ; SCPURPA -array of pointers to team purpose file 403.47 + ; if none are defined - returns all teams + ; if @SCPURPA@('exclude') is defined - exclude listed teams + ; SCROLEA - array of pointers to std position file 403.46 (per SCPURPA) + ; SCLIST -array name to store list + ; [ex. ^TMP("SCPT",$J)] + ; + ; SCERR = array NAME to store error messages. + ; [ex. ^TMP("ORXX",$J)] + ; + ; Output: + ; SCLIST() = array of positions (includes SCTP xref) + ; Format: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of TEAM POSITION File (#404.57) + ; 2 Name of Position + ; 3 IEN of Team #404.51 + ; 4 IEN of file #404.59 (Tm Pos History) + ; 5 current effective date + ; 6 current inactivate date (if any) + ; 7 pointer to 403.46 (role) + ; 8 Name of Standard Role + ; 9 pointer to User Class (#8930) + ; 10 Name of User Class + ; Subscript: "SCTP",SCTM,IEN ="" + ; + ; SCERR() = Array of DIALOG file messages(errors) . + ; @SCERR@(0) = number of errors, undefined if none + ; Format: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of DIALOG file + ; Returned: 1 if ok, 0 if error + ; Other: + ; SCACTHIS = status (-1:err|0:inact|1:act)^404.52 ien ^actdt^inacdt + ; + ; +ST N SCPTTP,SCPTTP0,SCTP,SCR,SCACTHIS,SCTM,SCND,SCU,SCOK,SCP,SCTPCL + N SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS + ; -- initialize control variables + S SCOK=1 + G:'$$OKDATA CLTPQ + S SCTP=0 F S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:'SCTP D Q:'SCOK + .S SCTP0=$G(^SCTM(404.57,SCTP,0)) + .IF '$L(SCTP0) D + ..S SCPARM("POSITION")=$G(SCTP,"Undefined") + ..S SCPARM("CLINIC")=$G(SC44,"Undefined") + ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) + .S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2) + .S SCP=$P(^SCTM(404.51,+SCTM,0),U,3) + .Q:'$$OKARRAY^SCAPU1(.SCPURPA,.SCP) + .S SCR=+$P(^SCTM(404.57,SCTP,0),U,3) + .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR) + .S SCACTHIS=$$ACTHIST^SCAPMCU2(404.59,SCTP,SCDATES,SCERR,"SCTPCL") + .Q:'SCACTHIS + .D BLD^SCAPMC24(.SCLIST,SCTM,SCTP,SCACTHIS,SCR) +CLTPQ Q $G(@SCERR@(0))<1 + ; +OKDATA() ;check/setup variables - return 1 if ok; 0 if error + N SCOK + S SCOK=1 + D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) + IF '$D(^SC(+$G(SC44),0)) D S SCOK=0 + . S SCPARM("CLINIC")=$G(SC44,"Undefined") + . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) + Q SCOK Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC9.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC9.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMC9.m (revision 623) @@ -1,78 +1,78 @@ -SCAPMC9 ;ALB/REW - Team API's:PRCL ; JUN 26, 1995 - ;;5.3;Scheduling;**41,112,520**;AUG 13, 1993;Build 26 - ;;1.0 -PRCL(SC44,SCDATES,SCPOSA,SCUSRA,SCROLEA,SCLIST,SCERR) ;-- list of practitioners for clinic - ; input: - ; SC44 = ien of CLINIC [required] - ; SCDATES("BEGIN") = begin date to search (inclusive) - ; [default: TODAY] - ; ("END") = end date to search (inclusive) - ; [default: TODAY] - ; ("INCL") = 1: only use pracitioners who were on - ; team for entire date range - ; 0: anytime in date range - ; [default: 1] - ; SCPOSA= array of positions to include reverse with scposa('exclude') - ; SCUSRA= array of usr classes included reverse with scusra('exclude') - ; SCROLEA= array of roles included reverse with SCROLEA('exclude') - ; SCERR = array NAME to store error messages. - ; [ex. ^TMP("ORXX",$J)] - ; - ; Output: - ; SCLIST() = array of practitioners - ; Format: - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of NEW PERSON file entry (#200) - ; 2 Name of person - ; 3 IEN of TEAM POSITION file (#404.57) - ; 4 Name of Position - ; 5 IEN OF USR CLASS(#8930) of POSITION (#404.57) - ; 6 USR Class Name - ; 7 IEN of STANDARD POSITION (#403.46) - ; 8 Standard Role (Position) Name - ; 9 Activation Date for 404.52 (not 404.59!) - ; 10 Inactivation Date for 404.52 - ; 11 IEN of Position Ass History (404.52) - ; 12 IEN of Preceptor Position - ; 13 Name of Preceptor Position - ; @sclist@('scpr',sc200,sctp,scact,scn)="" - ; - ; SCERR() = Array of DIALOG file messages(errors) . - ; Foramt: - ; @SCERR@(0) = Number of errors, undefined if none - ; Subscript: Sequential # from 1 to n - ; Piece Description - ; 1 IEN of DIALOG file - ; Returned: 1 if ok, 0 if error - ; - ; -ST N SCPOSNM,SCTP,SCPOS0,SCOK,SCND,SCU,SCR,SCPRCL - N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS - ; -- initialize control variables - G:'$$OKDATA PRACQ ; check/setup variables - ; -- loop through team positions - S SCTP=0 - F S SCTP=$O(^SCTM(404.57,"E",SC44,SCTP)) Q:SCTP="" D - .Q:'$$OKARRAY^SCAPU1(.SCPOSA,SCTP) - .S SCND=$G(^SCTM(404.57,SCTP,0)) - .S SCU=$P(SCND,U,13) - .Q:'$$OKUSRCL^SCAPU1(.SCUSRA,SCU) - .S SCR=$P(SCND,U,3) - .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR) - .IF 'SCTP D Q - ..S SCPARM("Position")=$G(SCTP,"Undefined") - ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",SCERR) - .ELSE D - ..S SCX=$$ACTHIST^SCAPMCU2(404.52,SCTP,SCDATES,.SCERR,"SCPRCL") - ..S:SCX X=$$PRTP^SCAPMC8(SCTP,SCDATES,.SCLIST,.SCERR) -PRACQ Q $G(@SCERR@(0))<1 -OKDATA() ;check/setup variables - return 1 if ok/ 0 if error - N SCOK - S SCOK=1 - D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) - ; - IF '$D(^SC(+$G(SC44),0)) D S SCOK=0 - . S SCPARM("CLINIC")=$G(SC44,"Undefined") - . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) - Q SCOK +SCAPMC9 ;ALB/REW - Team API's:PRCL ; JUN 26, 1995 + ;;5.3;Scheduling;**41,112**;AUG 13, 1993 + ;;1.0 +PRCL(SC44,SCDATES,SCPOSA,SCUSRA,SCROLEA,SCLIST,SCERR) ;-- list of practitioners for clinic + ; input: + ; SC44 = ien of CLINIC [required] + ; SCDATES("BEGIN") = begin date to search (inclusive) + ; [default: TODAY] + ; ("END") = end date to search (inclusive) + ; [default: TODAY] + ; ("INCL") = 1: only use pracitioners who were on + ; team for entire date range + ; 0: anytime in date range + ; [default: 1] + ; SCPOSA= array of positions to include reverse with scposa('exclude') + ; SCUSRA= array of usr classes included reverse with scusra('exclude') + ; SCROLEA= array of roles included reverse with SCROLEA('exclude') + ; SCERR = array NAME to store error messages. + ; [ex. ^TMP("ORXX",$J)] + ; + ; Output: + ; SCLIST() = array of practitioners + ; Format: + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of NEW PERSON file entry (#200) + ; 2 Name of person + ; 3 IEN of TEAM POSITION file (#404.57) + ; 4 Name of Position + ; 5 IEN OF USR CLASS(#8930) of POSITION (#404.57) + ; 6 USR Class Name + ; 7 IEN of STANDARD POSITION (#403.46) + ; 8 Standard Role (Position) Name + ; 9 Activation Date for 404.52 (not 404.59!) + ; 10 Inactivation Date for 404.52 + ; 11 IEN of Position Ass History (404.52) + ; 12 IEN of Preceptor Position + ; 13 Name of Preceptor Position + ; @sclist@('scpr',sc200,sctp,scact,scn)="" + ; + ; SCERR() = Array of DIALOG file messages(errors) . + ; Foramt: + ; @SCERR@(0) = Number of errors, undefined if none + ; Subscript: Sequential # from 1 to n + ; Piece Description + ; 1 IEN of DIALOG file + ; Returned: 1 if ok, 0 if error + ; + ; +ST N SCPOSNM,SCTP,SCPOS0,SCOK,SCND,SCU,SCR,SCPRCL + N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS + ; -- initialize control variables + G:'$$OKDATA PRACQ ; check/setup variables + ; -- loop through team positions + S SCTP=0 + F S SCTP=$O(^SCTM(404.57,"D",SC44,SCTP)) Q:SCTP="" D + .Q:'$$OKARRAY^SCAPU1(.SCPOSA,SCTP) + .S SCND=$G(^SCTM(404.57,SCTP,0)) + .S SCU=$P(SCND,U,13) + .Q:'$$OKUSRCL^SCAPU1(.SCUSRA,SCU) + .S SCR=$P(SCND,U,3) + .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR) + .IF 'SCTP D Q + ..S SCPARM("Position")=$G(SCTP,"Undefined") + ..D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",SCERR) + .ELSE D + ..S SCX=$$ACTHIST^SCAPMCU2(404.52,SCTP,SCDATES,.SCERR,"SCPRCL") + ..S:SCX X=$$PRTP^SCAPMC8(SCTP,SCDATES,.SCLIST,.SCERR) +PRACQ Q $G(@SCERR@(0))<1 +OKDATA() ;check/setup variables - return 1 if ok/ 0 if error + N SCOK + S SCOK=1 + D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined) + ; + IF '$D(^SC(+$G(SC44),0)) D S SCOK=0 + . S SCPARM("CLINIC")=$G(SC44,"Undefined") + . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR) + Q SCOK Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCAPMCU2.m (revision 623) @@ -1,217 +1,214 @@ -SCAPMCU2 ;ALB/REW - TEAM API UTILITIES ;6/29/99 19:40 ; Compiled May 29, 2007 15:16:13 - ;;5.3;Scheduling;**41,177,205,458**;AUG 13, 1993;Build 14 - ;;1.0 -DTAFTER(FILE,IEN,STATUS,DATE) ;return next date after given one - N SCX - S SCX=-1 - G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF - S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" - S EFFDT=-DATE - S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2) -QTDTAF Q SCX - ; -DTBEFORE(FILE,IEN,STATUS,DATE) ;return next date before given one - N SCX - S SCX=-1 - G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF - S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" - S EFFDT=-DATE - S SCX=$P($O(@ROOT@(EFFDT)),"-",2) -QTDTBF Q SCX - ; -ACTHISTB(FILE,IEN) ;boolean active function - ;abbreviated form of call below - no error handling - N X,SCACTB - S X=+$$ACTHIST(.FILE,.IEN,"SCACTB") - Q $S(X=1:1,1:0) - ; -ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST) ;is entry active for a time period? - ; Input Parameters: - ; File = either 404.52 or 404.58 or 404.59 - ; IEN = pointer to team(404.51) or team position(404.57) - ; SCDATES = (SEE PRIOR DEFINITION) - ; SCLIST = Output array - ; Returned: - ; status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt - ; which ien depends on status - ; - N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE - S OK=-1,X="" - G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH - S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT" - D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined) - IF 'OK S OK=-1 G QTACTH - S SCDATE=SCEND - S OK=0 - ;if incl=0 ->a partial hit should be returned -LOOP IF 'SCINCL D - .F S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) S SCA=$P(X,U,2),SCE=$P(X,U,3) D Q:$P(X,U,5)!(SCESCBEGIN) D - ..S OK=1 - ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2))) - ..S SCN=$G(@SCLIST@(FILE,0),0)+1 - ..S @SCLIST@(FILE,0)=SCN - ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3) - ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)="" -QTACTH Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3) - ; -EXT(FILE,IEN) ;return external value of team or team position file - N SCEXT - S SCEXT=-1 - IF FILE=404.58 D - .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1) - .S:'$L(SCEXT) SCEXT=-1 - IF "^404.52^404.53^404.59^"[(U_FILE_U) D - .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1) - .S:'$L(SCEXT) SCEXT=-1 -QTEXT Q SCEXT - ; -GETPC(DFN,DATE,PCROLE,ASSTYPE) ;return pc position & team for a date - ; DFN - pointer to patient file - ; DATE - date of interest (Default=DT) - ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending - ; ASSTYPE - Default=1 (PC Team) - ; returns sctp^sctm^assigned to pc? - ; - N ACTDT,SCTP,SCTM,SCPTA,INACTDT - Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0) - ; -HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date - ;return -1 if error, 0 if no active entry or 404.43 ien if one - Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1 - N SCACT,HISTIEN,SCINACT,SCDT - S SCDT=DATE+.00000001 - S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1) - S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0)) - S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4) - Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) - ; -HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date - ; return -1 if error, 0 if no active entry or 404.42 entyr if one - Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1 - N SCACT,HISTIEN,SCINACT,SCDT - S SCDT=DATE+.00000001 - S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT)) - S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0)) - S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9) - Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) - ; -GETPCTM(DFN,DATE,ASSTYPE) ;return pc team for a date - ; DFN - pointer to patient file - ; DATE - date of interest - ; ASSTYPE - Default=1 (PC Team) - ; returns sctm - ; - N ACTDT,SCTP,SCPTTMA,SCINDT,SCTM,SCGOOD - S ASSTYPE=$G(ASSTYPE,1) - S DATE=$G(DATE,DT) - ; returns pointer to 404.51, if exists, 0 if not - S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1) - I 'ACTDT Q 0 - S SCTM=0,SCGOOD=0 - F S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,SCTM)) Q:SCTM="" D Q:SCGOOD - .S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,""),-1) - .S SCINDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9) - .I SCINDT="" S SCGOOD=1 Q - Q $S('SCINDT:+SCTM,(SCINDT'0:-1,1:TPLP) Q - .I INACTDT'0:-1,1:TPLP) - .Q - Q +SCTP - ; -GETPRTP(SCTP,DATE) ;returns ien & name of practitioner filling position - ; Returned [Error:-1,Else: sc200^practname] - N X,SCPRDTS,SCPR - S DATE=$G(DATE,DT) - S SCPRDTS("BEGIN")=DATE - S SCPRDTS("END")=DATE - S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR") - Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2)) - ; -EXTMPRTP(SCTP,DATE) ;returns external of team and practitioner for position - ; - N SCX - S SCX=$$GETPRTP(.SCTP,.DATE) - Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_" "_$P(SCX,U,2) - ; -NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position - ; (See GETPCTP for variables) - N X - S X=$$GETPCTP(DFN,.DATE,.PCROLE) - Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1)) - ; -NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position - ; DFN - pointer to patient file - ; DATE - date of interest - ; PCROLE - Practitioner Position where '1' = PC provider - ; '2' = PC attending - ; '3' = PC associate provider - ; - ; returns sctp (ien^name), or "" if none or -1 if error - ; - N SCTP,PCAP - ;bp/cmf 205 original code next line - ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1 - ;bp/cmf 205 change code begin - ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) - S (PCROLE,PCAP)=+$G(PCROLE,1) - S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP) - S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) - ;bp/cmf 205 change code end - S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE) - Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP)) - ; -NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team - ; (See GETPCTM for variables) - N X - S X=$$GETPCTM(DFN,.DATE,.PCROLE) - Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1)) - ; -ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only - ; returns array sorted by 2nd piece's value - ; it keeps the 0 node -it does not return any x-ref values - ; it only converts arrays of type 1-n to another 1-n array - N SCNDX,SCX,SCNODE,SCY - S (SCX,SCY)=0 - S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0) - F S SCX=$O(@INARRAY@(SCX)) Q:'SCX S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE) D - .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)="" - S SCNDX="" - F S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX="" D - .S SCX=0 - .F S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX D - ..S SCY=SCY+1 - ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX)) - K ^TMP($J,"SCTMPSORT","B") - Q +SCAPMCU2 ;ALB/REW - TEAM API UTILITIES ;6/29/99 19:40 + ;;5.3;Scheduling;**41,177,205**;AUG 13, 1993 + ;;1.0 +DTAFTER(FILE,IEN,STATUS,DATE) ;return next date after given one + N SCX + S SCX=-1 + G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTAF + S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" + S EFFDT=-DATE + S SCX=$P($O(@ROOT@(EFFDT),-1),"-",2) +QTDTAF Q SCX + ; +DTBEFORE(FILE,IEN,STATUS,DATE) ;return next date before given one + N SCX + S SCX=-1 + G:('$G(FILE))!("^404.52^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTDTBF + S ROOT="^SCTM("_FILE_",""AIDT"",IEN,STATUS)" + S EFFDT=-DATE + S SCX=$P($O(@ROOT@(EFFDT)),"-",2) +QTDTBF Q SCX + ; +ACTHISTB(FILE,IEN) ;boolean active function + ;abbreviated form of call below - no error handling + N X,SCACTB + S X=+$$ACTHIST(.FILE,.IEN,"SCACTB") + Q $S(X=1:1,1:0) + ; +ACTHIST(FILE,IEN,SCDATES,SCERR,SCLIST) ;is entry active for a time period? + ; Input Parameters: + ; File = either 404.52 or 404.58 or 404.59 + ; IEN = pointer to team(404.51) or team position(404.57) + ; SCDATES = (SEE PRIOR DEFINITION) + ; SCLIST = Output array + ; Returned: + ; status (-1:error|0:inactive|1:active)^ien for file^actdt^inacdt + ; which ien depends on status + ; + N OK,X,ROOT,SCBEGIN,SCEND,SCINCL,SCDATE,SCA,SCDTS,SCE + S OK=-1,X="" + G:('$G(FILE))!("^404.52^404.53^404.58^404.59^"'[$G(FILE))!('$G(IEN)) QTACTH + S ROOT="^SCTM("_FILE_",""AIDT"",IEN,SCSTAT" + D INIT^SCAPMCU1(.OK) ; set default dates,output & error array (if undefined) + IF 'OK S OK=-1 G QTACTH + S SCDATE=SCEND + S OK=0 + ;if incl=0 ->a partial hit should be returned +LOOP IF 'SCINCL D + .F S X=$$DATES^SCAPMCU1(.FILE,.IEN,.SCDATE) S SCA=$P(X,U,2),SCE=$P(X,U,3) D Q:$P(X,U,5)!(SCESCBEGIN) D + ..S OK=1 + ..Q:$D(@SCLIST@(FILE,"SCLST",IEN,$P(X,U,2))) + ..S SCN=$G(@SCLIST@(FILE,0),0)+1 + ..S @SCLIST@(FILE,0)=SCN + ..S @SCLIST@(FILE,SCN)=IEN_U_$$EXT(FILE,IEN)_U_$P(X,U,2)_U_$P(X,U,3) + ..S @SCLIST@(FILE,"SCLST",IEN,$P(X,U,2),SCN)="" +QTACTH Q OK_U_$P(X,U,4)_U_$P(X,U,2)_U_$P(X,U,3) + ; +EXT(FILE,IEN) ;return external value of team or team position file + N SCEXT + S SCEXT=-1 + IF FILE=404.58 D + .S SCEXT=$P($G(^SCTM(404.51,+$G(IEN),0)),U,1) + .S:'$L(SCEXT) SCEXT=-1 + IF "^404.52^404.53^404.59^"[(U_FILE_U) D + .S SCEXT=$P($G(^SCTM(404.57,+$G(IEN),0)),U,1) + .S:'$L(SCEXT) SCEXT=-1 +QTEXT Q SCEXT + ; +GETPC(DFN,DATE,PCROLE,ASSTYPE) ;return pc position & team for a date + ; DFN - pointer to patient file + ; DATE - date of interest (Default=DT) + ; PCROLE - Default=1 (PC Practitioner Position) note 2= pc attending + ; ASSTYPE - Default=1 (PC Team) + ; returns sctp^sctm^assigned to pc? + ; + N ACTDT,SCTP,SCTM,SCPTA,INACTDT + Q $$GETPCTP(.DFN,.DATE,.PCROLE)_U_$$GETPCTM(.DFN,.DATE,.ASSTYPE)_U_($D(^SCPT(404.41,"APC",+DFN))>0) + ; +HISTPTTP(DFN,SCTP,DATE) ;404.43 entry for pt,position - if active on date + ;return -1 if error, 0 if no active entry or 404.43 ien if one + Q:'$G(DFN)!('$G(SCTP))!('$G(DATE)) -1 + N SCACT,HISTIEN,SCINACT,SCDT + S SCDT=DATE+.00000001 + S SCACT=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCDT),-1) + S HISTIEN=+$O(^SCPT(404.43,"ADFN",DFN,SCTP,SCACT,0)) + S SCINACT=$P($G(^SCPT(404.43,HISTIEN,0)),U,4) + Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) + ; +HISTPTTM(DFN,SCTM,DATE) ;404.42 entry for tm,position - if active on date + ; return -1 if error, 0 if no active entry or 404.42 entyr if one + Q:'$G(DFN)!('$G(SCTM))!('$G(DATE)) -1 + N SCACT,HISTIEN,SCINACT,SCDT + S SCDT=DATE+.00000001 + S SCACT=-$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCDT)) + S HISTIEN=+$O(^SCPT(404.42,"AIDT",DFN,SCTM,-SCACT,0)) + S SCINACT=$P($G(^SCPT(404.42,HISTIEN,0)),U,9) + Q $S('SCACT:0,('HISTIEN):0,('SCINACT):HISTIEN,(DATE>SCINACT):0,1:HISTIEN) + ; +GETPCTM(DFN,DATE,ASSTYPE) ;return pc team for a date + ; DFN - pointer to patient file + ; DATE - date of interest + ; ASSTYPE - Default=1 (PC Team) + ; returns sctm + ; + N ACTDT,SCTP,SCPTTMA,INACTDT,SCTM + S ASSTYPE=$G(ASSTYPE,1) + S DATE=$G(DATE,DT) + ; returns pointer to 404.51, if exists, 0 if not + S ACTDT=+$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,(DATE+.000001)),-1) + S SCTM=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,0)) + S SCPTTMA=$O(^SCPT(404.42,"APCTM",+DFN,+ASSTYPE,+ACTDT,+SCTM,0)) + S INACTDT=$P($G(^SCPT(404.42,+SCPTTMA,0)),U,9) + Q $S('INACTDT:+SCTM,(INACTDT'0:-1,1:TPLP) Q + .I INACTDT'0:-1,1:TPLP) + .Q + Q +SCTP + ; +GETPRTP(SCTP,DATE) ;returns ien & name of practitioner filling position + ; Returned [Error:-1,Else: sc200^practname] + N X,SCPRDTS,SCPR + S DATE=$G(DATE,DT) + S SCPRDTS("BEGIN")=DATE + S SCPRDTS("END")=DATE + S X=$$PRTP^SCAPMC(SCTP,"SCPRDTS","SCPR") + Q $S(X<1:-1,1:$P($G(SCPR(1)),U,1)_U_$P($G(SCPR(1)),U,2)) + ; +EXTMPRTP(SCTP,DATE) ;returns external of team and practitioner for position + ; + N SCX + S SCX=$$GETPRTP(.SCTP,.DATE) + Q $P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+SCTP,0)),U,2),0)),U,1)_" "_$P(SCX,U,2) + ; +NMPCTP(DFN,DATE,PCROLE) ;returns ien & name of pc position + ; (See GETPCTP for variables) + N X + S X=$$GETPCTP(DFN,.DATE,.PCROLE) + Q $S('$G(X):"",X=-1:"",1:X_U_$P($G(^SCTM(404.57,+X,0)),U,1)) + ; +NMPCPR(DFN,DATE,PCROLE) ;returns ien & name of pract filling pc position + ; DFN - pointer to patient file + ; DATE - date of interest + ; PCROLE - Practitioner Position where '1' = PC provider + ; '2' = PC attending + ; '3' = PC associate provider + ; + ; returns sctp (ien^name), or "" if none or -1 if error + ; + N SCTP,PCAP + ;bp/cmf 205 original code next line + ;S PCAP=PCROLE S:PCROLE=3 PCROLE=1 + ;bp/cmf 205 change code begin + ;;S PCROLE=+$G(PCROLE,1),(PCAP,PCROLE)=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) + S (PCROLE,PCAP)=+$G(PCROLE,1) + S PCAP=$S(PCAP=0:1,PCAP>3:1,1:PCAP) + S PCROLE=$S(PCROLE=0:1,PCROLE>2:1,1:PCROLE) + ;bp/cmf 205 change code end + S SCTP=+$$NMPCTP(.DFN,.DATE,.PCROLE) + Q $S('SCTP:"",1:$$PCPROV^SCAPMCU3(SCTP,.DATE,PCAP)) + ; +NMPCTM(DFN,DATE,PCROLE) ;returns ien & name of pc team + ; (See GETPCTM for variables) + N X + S X=$$GETPCTM(DFN,.DATE,.PCROLE) + Q $S('$G(X):"",1:X_U_$P($G(^SCTM(404.51,+X,0)),U,1)) + ; +ALPHA(INARRAY,OUTARRAY) ;not supported - for PCMM only + ; returns array sorted by 2nd piece's value + ; it keeps the 0 node -it does not return any x-ref values + ; it only converts arrays of type 1-n to another 1-n array + N SCNDX,SCX,SCNODE,SCY + S (SCX,SCY)=0 + S:$D(@INARRAY@(0)) @OUTARRAY@(0)=@INARRAY@(0) + F S SCX=$O(@INARRAY@(SCX)) Q:'SCX S SCNODE=@INARRAY@(SCX) Q:'$L(SCNODE) D + .S ^TMP($J,"SCTMPSORT","B",$P(SCNODE,U,2),SCX)="" + S SCNDX="" + F S SCNDX=$O(^TMP($J,"SCTMPSORT","B",SCNDX)) Q:SCNDX="" D + .S SCX=0 + .F S SCX=$O(^TMP($J,"SCTMPSORT","B",SCNDX,SCX)) Q:'SCX D + ..S SCY=SCY+1 + ..S @OUTARRAY@(SCY)=$G(@INARRAY@(SCX)) + K ^TMP($J,"SCTMPSORT","B") + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCDD2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCDD2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCDD2.m (revision 623) @@ -1,49 +1,49 @@ -SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996 - ;;5.3;Scheduling;**41,107,520**;AUG 13, 1993;Build 26 - ;1 -USEPCDEF(SCCL) ;how should pc practitioner be used for clinic - ; return 2=always default 1=default if no provider listed 0 -never - Q 2 -SETSCTM(SCTP,SCCL,SCTMNM) ;create 'TEAM' x-ref for Hospital Location File (#44) - ; x=sccl, da=sctp sctmnm=name of team - Q:'$G(SCTP)!('$G(SCCL)) - S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+$P(^SCTM(404.57,SCTP,0),U,2),0),U)) - S:$L(SCTMNM) ^SC("TEAM",SCTMNM,+SCCL)="" - Q - ; -KILLSCTM(SCTP,SCCL,SCTMNM) ;kill 'TEAM' x-ref for File #44 (if no other positions from team have this as associated clinic) - ; x=sccl, da=sctp sctmnm=name of team - N SCTM - Q:'$G(SCTP)!('$G(SCCL)) - S SCTM=+$P(^SCTM(404.57,SCTP,0),U,2) - S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+SCTM,0),U)) - K:$L(SCTMNM)&('$$OKTMCL(SCTM,SCTP,SCCL)) ^SC("TEAM",SCTMNM,+SCCL) - Q -OKTMCL(SCTM,SCTP,SCCL) ;does team have another position with this clinic as an assoicated clinic? - N SCXTP,SCOK - S SCOK=0 - S SCXTP=0 - F S SCXTP=$O(^SCTM(404.57,"E",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP) D - .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q - .S SCOK=1 - Q SCOK -STSCTMNM(SCTM,SCTMNM) ;if team name changes - set for 'TEAM' xrefs for file#44 - ; sctm=da sctmnm=x - Q:'$G(SCTM)!(SCTMNM="") - N SCTPNM,SCCL - S SCTPNM="" - F S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM="" D - .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique - .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9) - .D:SCCL SETSCTM(SCTP,SCCL,SCTMNM) - Q -KLSCTMNM(SCTM,SCTMNM) ;if team name changes - kill 'TEAM' xrefs for file #44 - ; sctm=da sctmnm=x - Q:'$G(SCTM)!(SCTMNM="") - N SCTPNM,SCCL - S SCTPNM="" - F S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM="" D - .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique - .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9) - .K:SCCL ^SC("TEAM",SCTMNM) - Q +SCMCDD2 ;ALB/REW - DD Calls used by PCMM ; 27 March 1996 + ;;5.3;Scheduling;**41,107**;AUG 13, 1993 + ;1 +USEPCDEF(SCCL) ;how should pc practitioner be used for clinic + ; return 2=always default 1=default if no provider listed 0 -never + Q 2 +SETSCTM(SCTP,SCCL,SCTMNM) ;create 'TEAM' x-ref for Hospital Location File (#44) + ; x=sccl, da=sctp sctmnm=name of team + Q:'$G(SCTP)!('$G(SCCL)) + S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+$P(^SCTM(404.57,SCTP,0),U,2),0),U)) + S:$L(SCTMNM) ^SC("TEAM",SCTMNM,+SCCL)="" + Q + ; +KILLSCTM(SCTP,SCCL,SCTMNM) ;kill 'TEAM' x-ref for File #44 (if no other positions from team have this as associated clinic) + ; x=sccl, da=sctp sctmnm=name of team + N SCTM + Q:'$G(SCTP)!('$G(SCCL)) + S SCTM=+$P(^SCTM(404.57,SCTP,0),U,2) + S SCTMNM=$G(SCTMNM,$P(^SCTM(404.51,+SCTM,0),U)) + K:$L(SCTMNM)&('$$OKTMCL(SCTM,SCTP,SCCL)) ^SC("TEAM",SCTMNM,+SCCL) + Q +OKTMCL(SCTM,SCTP,SCCL) ;does team have another position with this clinic as an assoicated clinic? + N SCXTP,SCOK + S SCOK=0 + S SCXTP=0 + F S SCXTP=$O(^SCTM(404.57,"D",SCCL,SCXTP)) Q:('SCXTP)!(SCXTP=SCTP) D + .I $P(^SCTM(404.57,SCXTP,0),U,2)'=SCTM Q + .S SCOK=1 + Q SCOK +STSCTMNM(SCTM,SCTMNM) ;if team name changes - set for 'TEAM' xrefs for file#44 + ; sctm=da sctmnm=x + Q:'$G(SCTM)!(SCTMNM="") + N SCTPNM,SCCL + S SCTPNM="" + F S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM="" D + .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique + .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9) + .D:SCCL SETSCTM(SCTP,SCCL,SCTMNM) + Q +KLSCTMNM(SCTM,SCTMNM) ;if team name changes - kill 'TEAM' xrefs for file #44 + ; sctm=da sctmnm=x + Q:'$G(SCTM)!(SCTMNM="") + N SCTPNM,SCCL + S SCTPNM="" + F S SCTPNM=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM)) Q:SCTPNM="" D + .S SCTP=$O(^SCTM(404.57,"ATMPOS",SCTM,SCTPNM,0)) ;note: name is unique + .S SCCL=$P($G(^SCTM(404.57,+SCTP,0)),U,9) + .K:SCCL ^SC("TEAM",SCTMNM) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLB1.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLB1.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLB1.m (revision 623) @@ -1,143 +1,145 @@ -SCMCHLB1 ;BPOI/DJB - PCMM HL7 Bld Segment Array Cont.;8/17/99 - ;;5.3;Scheduling;**177,515,524**;08/17/99;Build 29 - ; -SEGMENTS(DFN,SUB) ;Build EVN & PID segments - ;Input: - ; DFN - Patient IEN - ; SUB - Value for 1st Subscript - ;Output: - ; XMITARRY() - Array of EVN & PID segments - ; - NEW LINETAG,SEGMENTS,SEGNAME,SEGORD - NEW EVNTDATE,EVNTHL7,VAFARRY,VAFEVN,VAFPID,VAFSTR - ; - ;Initialize variables - Q:'$G(DFN) ;Required for PID segment - Q:'$G(SUB) - S EVNTDATE=DT - S EVNTHL7="A08" - ; - ;Get array of segments to be built - D SEGMENTS^SCMCHLS(EVNTHL7,"SEGMENTS") - ; - ;Loop thru segments array. Ignore ZPC segment - already built. - S SEGORD=0 - F S SEGORD=+$O(SEGMENTS(SEGORD)) Q:'SEGORD D ; - . S SEGNAME="" - . F S SEGNAME=$O(SEGMENTS(SEGORD,SEGNAME)) Q:SEGNAME="" D ; - .. Q:SEGNAME="ZPC" ;.................ZPC already built - .. S VAFSTR=SEGMENTS(SEGORD,SEGNAME) ;String of segment fields - .. S LINETAG="BLD"_SEGNAME - .. D @LINETAG^SCMCHLS ;...............Build segment - .. S LINETAG="CPY"_SEGNAME - .. D @LINETAG^SCMCHLS ;...............Copy segment into array - Q - ; -ZPC(ARRAY,DELETE) ;Loop thru array and build array of ZPC segments. - ; - ;Input: - ; ARRAY - Array to be processed. This array was built in ^SCMCHLB - ; with calls to $$PRTPC^SCAPMC() and $$PRPTTPC^SCAPMC(). - ; Examples: - ; ARRAY(2290,"PCP","2290-406-34-PCP")= Data - ; ARRAY(345,"PROV-P","2290-405-0-AP")= Data - ; DELETE - 1=Process a delete type ZPC segment (all fields null) - ;Output: - ; Array of ZPC segments - ; - NEW DATA,DATE,ID,ID1,LINETAG,SUB,TYPE,VAFZPC - ; - S SUB=0 - F S SUB=$O(ARRAY(SUB)) Q:'SUB D ; - . S TYPE="" - . F S TYPE=$O(ARRAY(SUB,TYPE)) Q:TYPE="" D ; - .. S ID="" - .. F S ID=$O(ARRAY(SUB,TYPE,ID)) Q:ID="" D ; - ... S DATA=$G(ARRAY(SUB,TYPE,ID)) - ... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment - ... E D ;....................A ZPC segment with data - .... ;Get dates - .... S DATE(9)=$P(DATA,U,9) - .... S DATE(10)=$P(DATA,U,10) - .... S DATE(14)=$P(DATA,U,14) ;Preceptor start date - .... S DATE(15)=$P(DATA,U,15) ;Preceptor end date - .... I DATE(14),DATE(14)>DATE(9) S DATE(9)=DATE(14) - .... I DATE(15) D ; - ..... I 'DATE(10) S DATE(10)=DATE(15) Q - ..... I DATE(15)DATE(9) S DATE(9)=DATE(14) + .... I DATE(15) D ; + ..... I 'DATE(10) S DATE(10)=DATE(15) Q + ..... I DATE(15) errors for NOIS BIG-1199-71271. - ; Replace local array POS() with global array. - S POS="^TMP(""PCMM"",""POS"","_$J_")" - KILL @POS - ; - S ID="" - F S ID=$O(^SCPT(404.49,"B",ID)) Q:ID="" D ; - . Q:$P(ID,"-",2)'=SCIEN - . S PTPI=$P(ID,"-",1) ;...............404.43 IEN - . S ND=$G(^SCPT(404.43,PTPI,0)) - . Q:($P(ND,U,5)'=1) ;................Must be Primary Care - . S DFN=$$DFN^SCMCHLB1(ND) Q:'DFN ;..Get patient - . ; - . S @POS@(DFN,PTPI,ID)="" ;djb/bp BIG-1199-71271 - . ; - Q:'$D(@POS) - ; - ;Process array - S DFN=0 - F S DFN=$O(@POS@(DFN)) Q:'DFN D ;djb/bp BIG-1199-71271 - . S PTPI=0 - . F S PTPI=$O(@POS@(DFN,PTPI)) Q:'PTPI D ;djb/bp BIG-1199-71271 - .. NEW SCSEQ ;djb/bp Added per Patch 210. - .. ;alb/rpm;Patch 224 Decrement max msg counter - .. I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1 - .. D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments - .. S ID="" - .. F S ID=$O(@POS@(DFN,PTPI,ID)) Q:ID="" D ;djb/bp BIG-1199-71271 - ... N SUB ; og/sd/524 - ... S SUB=PTPI,DATA="^^^" ;........A Delete type ZPC segment - ... ;djb/bp Patch 210. Eliminate indirection[rel 204] - ... D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA) - ... D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC) - ; - KILL @POS ;djb/bp BIG-1199-71271 - Q - ; -PRE ;Entry has been deleted from file 404.53. Send deletes to NPCD. - ;**** - ;Currently, deletes to 404.53 are not allowed if there are - ;patients assigned. - ;**** - ;alb/rpm;Patch 224 Decrement max msg counter - ;Uncomment the following line if this tag becomes active - ;I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1 - Q - ; -GETEVENT ;Get data from PCMM HL7 EVENT file - ;Return: DFN - Patient IEN - ; TP - Team Position - ; - NEW IEN,ND,PTR - ; - ;If in manual mode, get SCEVIEN (404.48 IEN). - I $G(SCMANUAL) D ; - . S (IEN,SCEVIEN)=0 - . F S IEN=$O(^SCPT(404.48,IEN)) Q:'IEN!SCEVIEN D ; - .. S PTR=$P($G(^(IEN,0)),U,7) Q:PTR="" - .. Q:PTR'=VARPTR - .. S SCEVIEN=IEN - ; - S ND=$G(^SCPT(404.48,SCEVIEN,0)) - S DFN=$P(ND,U,2) ;..Patient (DFN) - S TP=$P(ND,U,4) ;...Team Position - Q +SCMCHLB2 ;BP/DJB - PCMM HL7 Bld Segment Array Deletes ; 3/6/00 8:41am + ;;5.3;Scheduling;**177,204,210,224**;AUG 13, 1993 + ; +PTP ;Entry has been deleted from file 404.43. Send deletes to NPCD. + ; + NEW DFN,TP + D GETEVENT Q:'DFN ;..Get DFN & TP from PCMM HL7 EVENT file + D PTPD(SCIEN) ;.......Send delete + ;alb/rpm;Patch 224 Decrement max msg counter + I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1 + Q + ; +PTPD(PTPI) ;From PCMM HL7 ID file, get all ID's whose 1st piece equals PTPI, + ;and send a delete segment. + ;Input: PTPI - 404.43 IEN (1st piece of ID) + ; + ;djb/bp Added SCSEQ per Patch 210[rel 204]. + NEW DATA,ID,LINETAG,SCSEQ,VAFZPC + ; + S ID=PTPI_"-" + F S ID=$O(^SCPT(404.49,"B",ID)) Q:ID=""!($P(ID,"-",1)'=PTPI) D ; + . S DATA="^^^" ;........A Delete type ZPC segment + . ;djb/bp Patch 210. Eliminate indirection[rel 204] + . D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA) + . D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC) + Q:'$D(@XMITARRY) + D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments + Q + ; +POS ;Entry has been deleted from file 404.52. Send deletes to NPCD. + ; + NEW DATA,DFN,ID,LINETAG,ND,POS,PTPI,VAFZPC + ; + ;From PCMM HL7 ID file, get all ID's whose 2nd piece equals SCIEN, + ;Build array sorted by: DFN + ; 404.43 IEN + ; ID + ;djb/bp Fix errors for NOIS BIG-1199-71271. + ; Replace local array POS() with global array. + S POS="^TMP(""PCMM"",""POS"","_$J_")" + KILL @POS + ; + S ID="" + F S ID=$O(^SCPT(404.49,"B",ID)) Q:ID="" D ; + . Q:$P(ID,"-",2)'=SCIEN + . S PTPI=$P(ID,"-",1) ;...............404.43 IEN + . S ND=$G(^SCPT(404.43,PTPI,0)) + . Q:($P(ND,U,5)'=1) ;................Must be Primary Care + . S DFN=$$DFN^SCMCHLB1(ND) Q:'DFN ;..Get patient + . ; + . S @POS@(DFN,PTPI,ID)="" ;djb/bp BIG-1199-71271 + . ; + Q:'$D(@POS) + ; + ;Process array + S DFN=0 + F S DFN=$O(@POS@(DFN)) Q:'DFN D ;djb/bp BIG-1199-71271 + . S PTPI=0 + . F S PTPI=$O(@POS@(DFN,PTPI)) Q:'PTPI D ;djb/bp BIG-1199-71271 + .. NEW SCSEQ ;djb/bp Added per Patch 210. + .. ;alb/rpm;Patch 224 Decrement max msg counter + .. I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1 + .. D SEGMENTS^SCMCHLB1(DFN,PTPI) ;Bld array of EVN,PID segments + .. S ID="" + .. F S ID=$O(@POS@(DFN,PTPI,ID)) Q:ID="" D ;djb/bp BIG-1199-71271 + ... S DATA="^^^" ;........A Delete type ZPC segment + ... ;djb/bp Patch 210. Eliminate indirection[rel 204] + ... D BLDZPC^SCMCHLS ;..Build segment (needs ID & DATA) + ... D CPYZPC^SCMCHLS ;..Copy segment into array (needs ID & VAFZPC) + ; + KILL @POS ;djb/bp BIG-1199-71271 + Q + ; +PRE ;Entry has been deleted from file 404.53. Send deletes to NPCD. + ;**** + ;Currently, deletes to 404.53 are not allowed if there are + ;patients assigned. + ;**** + ;alb/rpm;Patch 224 Decrement max msg counter + ;Uncomment the following line if this tag becomes active + ;I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1 + Q + ; +GETEVENT ;Get data from PCMM HL7 EVENT file + ;Return: DFN - Patient IEN + ; TP - Team Position + ; + NEW IEN,ND,PTR + ; + ;If in manual mode, get SCEVIEN (404.48 IEN). + I $G(SCMANUAL) D ; + . S (IEN,SCEVIEN)=0 + . F S IEN=$O(^SCPT(404.48,IEN)) Q:'IEN!SCEVIEN D ; + .. S PTR=$P($G(^(IEN,0)),U,7) Q:PTR="" + .. Q:PTR'=VARPTR + .. S SCEVIEN=IEN + ; + S ND=$G(^SCPT(404.48,SCEVIEN,0)) + S DFN=$P(ND,U,2) ;..Patient (DFN) + S TP=$P(ND,U,4) ;...Team Position + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLR2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLR2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLR2.m (revision 623) @@ -1,132 +1,132 @@ -SCMCHLR2 ;ALB/KCL - PCMM HL7 Reject Processing - Build List Area; 10-JAN-2000 ; Compiled April 24, 2007 11:44:10 - ;;5.3;Scheduling;**210,272,297,458**;AUG 13, 1993;Build 14 - ; -EN(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY,SCCNT) ; - ; Description: This entry point is used to build list area for - ; PCMM Transmission Errors. - ; - ; The following variables are 'system wide variables' in the - ; PCMM Transmission Error Processing List Manager application: - ; Input: - ; SCARY - Global array subscript - ; SCBEG - Begin date for date range - ; SCEND - End date for date range - ; SCEPS - Error processing statuses - ; 1 -> New - ; 2 -> Checked - ; 3 -> Both - ; SCSORTBY - Sort by criteria - ; N -> Patient Name - ; D -> Date/Time Ack Received - ; P -> Provider - ; - ; Output: - ; SCCNT - Contains number of lines in the list, pass by reference - ; - ;Display FM wait msg - D WAIT^DICD - ; - ;Get PCMM HL7 Trans Log errors - D GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY) - ; - ;Build list area for PCMM HL7 Trans Log errors - D BLDLIST^SCMCHLR3(SCSORTBY,SCEPS,.SCCNT) - ; - ;If no PCMM HL7 Trans Log errors, display msg in list area - I 'SCCNT D - .D SET^SCMCHLR3(SCARY,1,"",1,36,0,,,,.SCCNT) - .D SET^SCMCHLR3(SCARY,2,"No 'PCMM Transmission Errors' to display.",4,41,0,,,,.SCCNT) - Q - ; - ; -GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY) ; - ; Description: Get PCMM HL7 Transmission Log errors. - ; - ; Input: - ; SCARY - Global array subscript - ; SCBEG - Begin date for date range - ; SCEND - End date for date range - ; SCEPS - Error processing status - ; SCSORTBY - Sort by criteria - ; - ; Output: - ; PCMM transmission log error list sorted by: - ; - ; Patient Name: ^TMP("SCERRSRT",$J,,,,) - ; OR, - ; Date/Time Ack Rec'd: ^TMP("SCERRSRT",$J,,,,) - ; OR, - ; Provider: ^TMP("SCERRSRT",$J,,,,) - ; - N SCDFN,SCDTR,SCERIEN,SCTLIEN,SCSTAT - ; - ;Loop thru PCMM HL7 Trans Log for selected date range - F SCDTR=SCBEG:0 S SCDTR=$O(^SCPT(404.471,"AST",SCDTR)) Q:'SCDTR!($P(SCDTR,".")>SCEND) D - .;loop thru status - .S SCSTAT=0 - .F S SCSTAT=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT)) Q:SCSTAT="" D - ..;loop thru patients - ..S SCDFN=0 - ..F S SCDFN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN)) Q:SCDFN="" D - ...;loop through (#404.471) ien's - ...S SCTLIEN=0 - ...F S SCTLIEN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN,SCTLIEN)) Q:'SCTLIEN D - ....;loop thru ien's of error code mult. and setup sort array - ....S SCERIEN=0 - ....F S SCERIEN=$O(^SCPT(404.471,SCTLIEN,"ERR",SCERIEN)) Q:'SCERIEN D SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN) - ; - Q - ; - ; -SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN) ; - ; Description: Used to set up sort array based on 'Sort Criteria' and - ; 'Error Processing Status' for PCMM Transmission Errors list display. - ; - ; Input: - ; SCSORTBY - Sort by criteria - ; SCDTR - PCMM transmission log date/time ack received - ; SCDFN - Patient IEN - ; SCEPS - Error processing status - ; SCTLIEN - PCMM transmission log IEN - ; SCERIEN - IEN of record in Error Code (#404.47142) multiple - ; - ; Output: None - ; - N SCTLOG - ; - ;If sort by criteria is 'Date/Time Ack Received' - I SCSORTBY="D" D - .;get data from PCMM HL7 Trans Log - .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D - ..;if Error Proc Status matches selected Error Proc Status - ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D - ...;setup ^tmp array sorted by date/time ack rec'd - ...S ^TMP("SCERRSRT",$J,SCSORTBY,SCDTR,SCTLIEN,SCERIEN)="" - ; - ;If sort by criteria is 'Provider' - I SCSORTBY="P" D - .N SCPTR,SCPROV,SCHL - .;get data from PCMM HL7 Trans Log - .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D - ..;if Error Proc Status matches selected Error Proc Status - ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D - ...;get data from PCMM HL7 ID file - ...I $$GETHL7ID^SCMCHLA2($G(SCTLOG("ERR","ZPCID")),.SCHL) D - ....;get provider from POSITION ASSIGNMENT HISTORY file - ....S SCPTR=$P($G(SCHL("HL7ID")),"-",2) ; pointer to PCMM HL7 ID file - ....I $G(SCTLOG("WORK")) S SCPROV=$$PROV^SCMCHLP(SCTLOG("WORK")) - ....I '$G(SCTLOG("WORK")) S SCPROV=$P($G(^SCTM(404.52,+SCPTR,0)),"^",3) - ....;setup ^tmp array sorted by provider - ....S ^TMP("SCERRSRT",$J,SCSORTBY,$S($G(SCPROV)'="":$$EXTERNAL^DILFD(404.52,.03,,SCPROV),1:"ZZZUNKNOWN"),SCTLIEN,SCERIEN)="" - ; - ;If sort by criteria is 'Patient' (default) - I SCSORTBY="N" D - .;get data from PCMM HL7 Trans Log - .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D - ..;if Error Proc Status matches selected Error Proc Status - ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D - ...;setup ^tmp array sorted by patient - ...I SCDFN="W" I $G(SCTLOG("WORK"))="" S SCDFN="" - ...S ^TMP("SCERRSRT",$J,SCSORTBY,$S($P($G(^DPT(+SCDFN,0)),U)'="":$P(^(0),U),SCDFN="W":"Workload Message",1:"UNKNOWN"),SCTLIEN,SCERIEN)="" - ; - Q +SCMCHLR2 ;ALB/KCL - PCMM HL7 Reject Processing - Build List Area; 10-JAN-2000 + ;;5.3;Scheduling;**210,272,297**;AUG 13, 1993 + ; +EN(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY,SCCNT) ; + ; Description: This entry point is used to build list area for + ; PCMM Transmission Errors. + ; + ; The following variables are 'system wide variables' in the + ; PCMM Transmission Error Processing List Manager application: + ; Input: + ; SCARY - Global array subscript + ; SCBEG - Begin date for date range + ; SCEND - End date for date range + ; SCEPS - Error processing statuses + ; 1 -> New + ; 2 -> Checked + ; 3 -> Both + ; SCSORTBY - Sort by criteria + ; N -> Patient Name + ; D -> Date/Time Ack Received + ; P -> Provider + ; + ; Output: + ; SCCNT - Contains number of lines in the list, pass by reference + ; + ;Display FM wait msg + D WAIT^DICD + ; + ;Get PCMM HL7 Trans Log errors + D GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY) + ; + ;Build list area for PCMM HL7 Trans Log errors + D BLDLIST^SCMCHLR3(SCSORTBY,SCEPS,.SCCNT) + ; + ;If no PCMM HL7 Trans Log errors, display msg in list area + I 'SCCNT D + .D SET^SCMCHLR3(SCARY,1,"",1,36,0,,,,.SCCNT) + .D SET^SCMCHLR3(SCARY,2,"No 'PCMM Transmission Errors' to display.",4,41,0,,,,.SCCNT) + Q + ; + ; +GET(SCARY,SCBEG,SCEND,SCEPS,SCSORTBY) ; + ; Description: Get PCMM HL7 Transmission Log errors. + ; + ; Input: + ; SCARY - Global array subscript + ; SCBEG - Begin date for date range + ; SCEND - End date for date range + ; SCEPS - Error processing status + ; SCSORTBY - Sort by criteria + ; + ; Output: + ; PCMM transmission log error list sorted by: + ; + ; Patient Name: ^TMP("SCERRSRT",$J,,,,) + ; OR, + ; Date/Time Ack Rec'd: ^TMP("SCERRSRT",$J,,,,) + ; OR, + ; Provider: ^TMP("SCERRSRT",$J,,,,) + ; + N SCDFN,SCDTR,SCERIEN,SCTLIEN,SCSTAT + ; + ;Loop thru PCMM HL7 Trans Log for selected date range + F SCDTR=SCBEG:0 S SCDTR=$O(^SCPT(404.471,"AST",SCDTR)) Q:'SCDTR!($P(SCDTR,".")>SCEND) D + .;loop thru status + .S SCSTAT=0 + .F S SCSTAT=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT)) Q:SCSTAT="" D + ..;loop thru patients + ..S SCDFN=0 + ..F S SCDFN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN)) Q:SCDFN="" D + ...;loop through (#404.471) ien's + ...S SCTLIEN=0 + ...F S SCTLIEN=$O(^SCPT(404.471,"AST",SCDTR,SCSTAT,SCDFN,SCTLIEN)) Q:'SCTLIEN D + ....;loop thru ien's of error code mult. and setup sort array + ....S SCERIEN=0 + ....F S SCERIEN=$O(^SCPT(404.471,SCTLIEN,"ERR",SCERIEN)) Q:'SCERIEN D SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN) + ; + Q + ; + ; +SORT(SCSORTBY,SCDTR,SCDFN,SCEPS,SCTLIEN,SCERIEN) ; + ; Description: Used to set up sort array based on 'Sort Criteria' and + ; 'Error Processing Status' for PCMM Transmission Errors list display. + ; + ; Input: + ; SCSORTBY - Sort by criteria + ; SCDTR - PCMM transmission log date/time ack received + ; SCDFN - Patient IEN + ; SCEPS - Error processing status + ; SCTLIEN - PCMM transmission log IEN + ; SCERIEN - IEN of record in Error Code (#404.47142) multiple + ; + ; Output: None + ; + N SCTLOG + ; + ;If sort by criteria is 'Date/Time Ack Received' + I SCSORTBY="D" D + .;get data from PCMM HL7 Trans Log + .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D + ..;if Error Proc Status matches selected Error Proc Status + ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D + ...;setup ^tmp array sorted by date/time ack rec'd + ...S ^TMP("SCERRSRT",$J,SCSORTBY,SCDTR,SCTLIEN,SCERIEN)="" + ; + ;If sort by criteria is 'Provider' + I SCSORTBY="P" D + .N SCPTR,SCPROV,SCHL + .;get data from PCMM HL7 Trans Log + .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D + ..;if Error Proc Status matches selected Error Proc Status + ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D + ...;get data from PCMM HL7 ID file + ...I $$GETHL7ID^SCMCHLA2($G(SCTLOG("ERR","ZPCID")),.SCHL) + ...;get provider from POSITION ASSIGNMENT HISTORY file + ...S SCPTR=$P($G(SCHL("HL7ID")),"-",2) ; pointer to PCMM HL7 ID file + ...I $G(SCTLOG("WORK")) S SCPROV=$$PROV^SCMCHLP(SCTLOG("WORK")) + ...I '$G(SCTLOG("WORK")) S SCPROV=$P($G(^SCTM(404.52,+SCPTR,0)),"^",3) + ...;setup ^tmp array sorted by provider + ...S ^TMP("SCERRSRT",$J,SCSORTBY,$S($G(SCPROV)'="":$$EXTERNAL^DILFD(404.52,.03,,SCPROV),1:"ZZZUNKNOWN"),SCTLIEN,SCERIEN)="" + ; + ;If sort by criteria is 'Patient' (default) + I SCSORTBY="N" D + .;get data from PCMM HL7 Trans Log + .I $$GETLOG^SCMCHLA(SCTLIEN,SCERIEN,.SCTLOG) D + ..;if Error Proc Status matches selected Error Proc Status + ..I (SCEPS=$G(SCTLOG("ERR","EPS"))!(SCEPS>2)) D + ...;setup ^tmp array sorted by patient + ...I SCDFN="W" I $G(SCTLOG("WORK"))="" S SCDFN="" + ...S ^TMP("SCERRSRT",$J,SCSORTBY,$S($P($G(^DPT(+SCDFN,0)),U)'="":$P(^(0),U),SCDFN="W":"Workload Message",1:"UNKNOWN"),SCTLIEN,SCERIEN)="" + ; + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLS.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLS.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCHLS.m (revision 623) @@ -1,107 +1,107 @@ -SCMCHLS ;BPOI/DJB - PCMM HL7 Segment Utils;12/13/99 - ;;5.3;Scheduling;**177,210,212,293,515,524**;08/13/93;Build 29 - ; - ;Ref rtn: SCDXMSG1 - ; - ;--> Build HL7 segments -BLDEVN ;Build EVN segment - S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,EVNTDATE,VAFSTR,HL("Q"),HL("FS")) - Q -BLDPID ;Build PID segment - ;S VAFPID=$$EN^VAFHLPID(DFN,VAFSTR) - S VAFPID=$$EN^VAFCPID(DFN,VAFSTR) ;Use CIRN version - D SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS")) - Q -BLDZPC ;Build ZPC segment - ;djb/bp Patch 210. Sequentially number multiple ZPC segments. - ;new code begin - S SCSEQ=$G(SCSEQ)+1 ;Increment ZPC sequence number. - ; S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA,SCSEQ) - S VAFZPC=$$ZPC^SCMCHLZ("",.ID,.DATA,SCSEQ) - ;new code end - ;old code begin - ;S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA) - ;old code end - Q - ; - ;--> Copy HL7 segments into HL7 message -CPYEVN ;Copy EVN segment - ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment - M @XMITARRY@(SUB,SEGNAME,1)=VAFEVN - Q -CPYPID ;Copy PID segment - ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment - M @XMITARRY@(SUB,SEGNAME,1)=VAFPID - Q -CPYZPC ;Copy ZPC segment - ; PATCH 515 DLL USE ORIG TRIG - ; old code = M @XMITARRY@($P(ID,"-",1),"ZPC",ID)=VAFZPC - M @XMITARRY@(SUB,"ZPC",ID)=VAFZPC ; og/sd/524 - Q - ; - ;--> Delete HL7 segment variables -DELEVN ;Delete EVN variable - KILL VAFEVN - Q -DELPID ;Delete PID variable - KILL VAFPID - Q -DELZPC ;Delete ZPC variable - KILL VAFZPC - Q - ; -SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given event type - ; - ; Input: EVNTTYPE - Event type to build list for A08 & A23 are the - ; only types currently supported. - ; Default=A08 - ; SEGARRY - Array to place output in (full global reference) - ; Defaul=^TMP("SCMC SEGMENTS",$J) - ;Output: SEGARRY(Seq,Name)=Fields - ; Seq - Sequence number to order segments as they should - ; be placed in the HL7 message. - ; Name - Name of HL7 segment. - ; Fields - List of fields used by PCMM. VAFSTR would be set - ; to this value. - ; Note: MSH segment is not included - ; - ;Check input - S EVNTTYPE=$G(EVNTTYPE) - S:(EVNTTYPE'="A23") EVNTTYPE="A08" - S SEGARRY=$G(SEGARRY) - S:(SEGARRY="") SEGARRY="^TMP(""SCMC SEGMENTS"","_$J_")" - ; - ;Segments used by A08 - S @SEGARRY@(1,"EVN")="1,2" - S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10N,11,12,13,14,16,17,19,22" - S @SEGARRY@(3,"ZPC")="1,2,3,4,5,6,8" ;bp/ar and alb/rpm Patch 212 - Q - ; -UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into transmit array. - ; - ; Input: XMITARRY - Array containing HL7 message (full global ref). - ; Default=^TMP("HLS",$J). - ; INSRTPNT - Where to begin deletion from. - ; Default=1 - ;Output: None - ; - ;Check input - S:$G(XMITARRY)="" XMITARRY="^TMP(""HLS"","_$J_")" - S:$G(INSRTPNT)="" INSRTPNT=1 - ; - ;Remove insertion point from array - KILL @XMITARRY@(INSRTPNT) - ;Remove everything from insertion point to end of array - F S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:INSRTPNT="" KILL @XMITARRY@(INSRTPNT) - ;Done - Q -COUNT(VALER) ;counts the number of errored encounters found. - ; - ; Input: VALER - Array containing error messages. - ;Output: Number of errors - ; - NEW VAR,CNT - S CNT=0 - S VAR="" - F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 - Q CNT +SCMCHLS ;BP/DJB - PCMM HL7 Segment Utils ; 12/13/99 12:40pm + ;;5.3;Scheduling;**177,210,212,293,515**;AUG 13, 1993;Build 14 + ; + ;Ref rtn: SCDXMSG1 + ; + ;--> Build HL7 segments +BLDEVN ;Build EVN segment + S VAFEVN=$$EN^VAFHLEVN(EVNTHL7,EVNTDATE,VAFSTR,HL("Q"),HL("FS")) + Q +BLDPID ;Build PID segment + ;S VAFPID=$$EN^VAFHLPID(DFN,VAFSTR) + S VAFPID=$$EN^VAFCPID(DFN,VAFSTR) ;Use CIRN version + D SETMAR^SCMSVUT0(.VAFPID,HL("Q"),HL("FS")) + Q +BLDZPC ;Build ZPC segment + ;djb/bp Patch 210. Sequentially number multiple ZPC segments. + ;new code begin + S SCSEQ=$G(SCSEQ)+1 ;Increment ZPC sequence number. + ; S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA,SCSEQ) + S VAFZPC=$$ZPC^SCMCHLZ("",.ID,.DATA,SCSEQ) + ;new code end + ;old code begin + ;S VAFZPC=$$ZPC^SCMCHLZ("",ID,DATA) + ;old code end + Q + ; + ;--> Copy HL7 segments into HL7 message +CPYEVN ;Copy EVN segment + ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment + M @XMITARRY@(SUB,SEGNAME,1)=VAFEVN + Q +CPYPID ;Copy PID segment + ;Add 1 as 3rd subscript so number of subscripts matches ZPC segment + M @XMITARRY@(SUB,SEGNAME,1)=VAFPID + Q +CPYZPC ;Copy ZPC segment + ; PATCH 515 DLL USE ORIG TRIG + ; old code = M @XMITARRY@($P(ID,"-",1),"ZPC",ID)=VAFZPC + M @XMITARRY@(NUM,"ZPC",ID)=VAFZPC + Q + ; + ;--> Delete HL7 segment variables +DELEVN ;Delete EVN variable + KILL VAFEVN + Q +DELPID ;Delete PID variable + KILL VAFPID + Q +DELZPC ;Delete ZPC variable + KILL VAFZPC + Q + ; +SEGMENTS(EVNTTYPE,SEGARRY) ;Build list of HL7 segments for a given event type + ; + ; Input: EVNTTYPE - Event type to build list for A08 & A23 are the + ; only types currently supported. + ; Default=A08 + ; SEGARRY - Array to place output in (full global reference) + ; Defaul=^TMP("SCMC SEGMENTS",$J) + ;Output: SEGARRY(Seq,Name)=Fields + ; Seq - Sequence number to order segments as they should + ; be placed in the HL7 message. + ; Name - Name of HL7 segment. + ; Fields - List of fields used by PCMM. VAFSTR would be set + ; to this value. + ; Note: MSH segment is not included + ; + ;Check input + S EVNTTYPE=$G(EVNTTYPE) + S:(EVNTTYPE'="A23") EVNTTYPE="A08" + S SEGARRY=$G(SEGARRY) + S:(SEGARRY="") SEGARRY="^TMP(""SCMC SEGMENTS"","_$J_")" + ; + ;Segments used by A08 + S @SEGARRY@(1,"EVN")="1,2" + S @SEGARRY@(2,"PID")="1,2,3,4,5,6,7,8,10N,11,12,13,14,16,17,19,22" + S @SEGARRY@(3,"ZPC")="1,2,3,4,5,6,8" ;bp/ar and alb/rpm Patch 212 + Q + ; +UNWIND(XMITARRY,INSRTPNT) ;Remove all data that was put into transmit array. + ; + ; Input: XMITARRY - Array containing HL7 message (full global ref). + ; Default=^TMP("HLS",$J). + ; INSRTPNT - Where to begin deletion from. + ; Default=1 + ;Output: None + ; + ;Check input + S:$G(XMITARRY)="" XMITARRY="^TMP(""HLS"","_$J_")" + S:$G(INSRTPNT)="" INSRTPNT=1 + ; + ;Remove insertion point from array + KILL @XMITARRY@(INSRTPNT) + ;Remove everything from insertion point to end of array + F S INSRTPNT=$O(@XMITARRY@(INSRTPNT)) Q:INSRTPNT="" KILL @XMITARRY@(INSRTPNT) + ;Done + Q +COUNT(VALER) ;counts the number of errored encounters found. + ; + ; Input: VALER - Array containing error messages. + ;Output: Number of errors + ; + NEW VAR,CNT + S CNT=0 + S VAR="" + F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 + Q CNT Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCMU2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCMU2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCMU2.m (revision 623) @@ -1,243 +1,243 @@ -SCMCMU2 ;ALBOI/MJK - PCMM Mass Team/Position Unassignment Processing;07/10/98 - ;;5.3;Scheduling;**148,177,524**;AUG 13, 1993;Build 29 - ; -QUE() ; -- queue mass unassignment - ;D START Q 99999 ; -- for interactive testing - N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK - S ZTRTN="START^SCMCMU2" - S ZTDESC=VALM("TITLE") - S ZTDTH=$H - S ZTIO="" - F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)="" - F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)="" - D ^%ZTLOAD - Q $G(ZTSK) - ; -START ; -- entry point for task - ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT - ; - N SCTOP,SCUNCNT,SCASCNT,SCOK - S SCUNCNT=0 - S SCASCNT=SCSELCNT - ; - ; -- lock top node - IF SCMUTYPE="T" D - . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0)) - ELSE IF SCMUTYPE="P" D - . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0)) - D LOCK(SCTOP) - ; - ; -- use tmp data brought in by TaskMan - N SCPTSEL,SCPTINFO - S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED")) - S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO")) - ; - N SCOKAR,SCBADAR,SCERRAR,SCPTTP - S SCOKAR=$NA(^TMP("SCMU",$J,"OK")) - S SCBADAR=$NA(^TMP("SCMU",$J,"BAD")) - S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR")) - S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION")) - K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP - ; - N SCNT,SCNODE,SCPTX - ; - ; -- create patient-position array for team processing - IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP) - ; - S SCNT=0 - F S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT D - . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing - . S SCPTX=$G(@SCPTINFO@(SCNT)) - . IF SCPTX="" Q - . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) - . ; - . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX) - . ; - . ; -- if successful - . IF SCOK D - . . S @SCOKAR@(SCNT)="" - . . S SCUNCNT=SCUNCNT+1 - . . S SCASCNT=SCASCNT-1 - . ; - . ; -- if not sucessful - . ELSE D - . . S @SCBADAR@(SCNT)="" - ; - ; -- unlock top node - D UNLOCK(SCTOP) - ; - ; -- send results - D BULL^SCMCMU4 - ; - K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP - K @SCPTSEL,@SCPTINFO - Q - ; - ; **** May want to eventually combine TMDIS & TPDIS tags **** - ; -TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient - ; input: SCDATE := effective date - ; SCTEAM := ien of TEAM entry (404.51) - ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays - ; SCPTX := format defined by output of $$PTTM^SCAPMC2 - ; - N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT - ; - S SCOK=1 - S SCERRS="SCERRLST" - ; - S DFN=+SCPTX - S SCIEN=+$P(SCPTX,U,3) - S SCNODE=$NA(^SCPT(404.42,SCIEN,0)) - S SCASDT=+$P(SCPTX,U,4) - S SCUNDT=+$P(SCPTX,U,5) - ; - ; -- unassign from positions first - S SCPOS=0 - F S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS D Q:'SCOK - . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS))) - ; - IF 'SCOK D - . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient." - . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position." - ; - IF SCOK D - . ; -- if assignment date is in future then delete - . IF SCASDT>DT,SCASDT>SCDATE D Q - . . N DA,DIK - . . S DA=SCIEN,DIK="^SCPT(404.42," - . . D LOCK(SCNODE) - . . D ^DIK - . . D UNLOCK(SCNODE) - . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted." - . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN - . . Q - . ; - . ; -- if assignment date is after effective date but before today - . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D - . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed." - . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" - ; - Q SCOK - ; -TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient - ; input: SCDATE := effective date - ; SCTEAM := ien of TEAM POSITION entry (404.57) - ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays - ; SCPTX := format defined by output of $$PTTP^SCAPMC2 - ; - N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT - S SCASDT=+$P(SCPTX,U,4) - S SCUNDT=+$P(SCPTX,U,5) - ; - S SCOK=1 - S SCERRS="SCERRLST" - ; - S DFN=+SCPTX - S SCIEN=+$P(SCPTX,U,3) - S SCNODE=$NA(^SCPT(404.43,SCIEN,0)) - S SCASDT=+$P(SCPTX,U,4) - S SCUNDT=+$P(SCPTX,U,5) - ; - ; if assignment date is in future then delete - IF SCOK D - . ; -- if assignment date is in future then delete - . IF SCASDT>DT,SCASDT>SCDATE D Q - . . N DA,DIE,DIK,DR - . . S DA=SCIEN,(DIE,DIK)="^SCPT(404.43,",DR=".04///"_DT D ^DIE ; og/sd/524 - . . D LOCK(SCNODE) - . . D ^DIK - . . D UNLOCK(SCNODE) - . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted." - . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN - . . Q - . ; - . ; -- if assignment date is after effective date but before today - . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D - . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed." - . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" - . . Q - ; - IF SCOK D - . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS) - . Q - ; -TPDISQ Q SCOK - ; -CLDIS(SCPOS) ; -- discharge from clinic - N SCPOS0,SCCLN,SCREA,SCRET - S SCRET="" - ; - ; -- if user did not request clinic discharge, quit - IF '$G(SCTPDIS(+SCPOS)) G CLDISQ - ; - S SCPOS0=$G(^SCTM(404.57,SCPOS,0)) - S SCCLN=$P(SCPOS0,U,9) - IF SCCLN D - . S SCREA="Team position mass discharge" - . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA) - . Q - ELSE D - . S SCRET="0^No clinic assignment to position" - . Q - ; -CLDISQ Q SCRET - ; -LOCK(NODE) ; -- lock node - F L +@NODE:5 IF $T Q - Q - ; -UNLOCK(NODE) ; -- unlock node - L -@NODE - Q - ; +SCMCMU2 ;ALB/MJK - PCMM Mass Team/Position Unassignment Processing ; 10-JUL-1998 + ;;5.3;Scheduling;**148,177**;AUG 13, 1993 + ; +QUE() ; -- queue mass unassignment + ;D START Q 99999 ; -- for interactive testing + N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,ZTSK + S ZTRTN="START^SCMCMU2" + S ZTDESC=VALM("TITLE") + S ZTDTH=$H + S ZTIO="" + F X="SCTEAM","SCPOS","SCTPDIS(","SCMUTYPE","SCDATE","SCSELCNT" S ZTSAVE(X)="" + F X="^TMP(""SCMU"",$J,""SELECTED"",","^TMP(""SCMU"",$J,""PATIENT INFO""," S ZTSAVE(X)="" + D ^%ZTLOAD + Q $G(ZTSK) + ; +START ; -- entry point for task + ; -- defined from task SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE,SCSELCNT + ; + N SCTOP,SCUNCNT,SCASCNT,SCOK + S SCUNCNT=0 + S SCASCNT=SCSELCNT + ; + ; -- lock top node + IF SCMUTYPE="T" D + . S SCTOP=$NA(^SCTM(404.51,+SCTEAM,0)) + ELSE IF SCMUTYPE="P" D + . S SCTOP=$NA(^SCTM(404.57,+SCPOS,0)) + D LOCK(SCTOP) + ; + ; -- use tmp data brought in by TaskMan + N SCPTSEL,SCPTINFO + S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED")) + S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO")) + ; + N SCOKAR,SCBADAR,SCERRAR,SCPTTP + S SCOKAR=$NA(^TMP("SCMU",$J,"OK")) + S SCBADAR=$NA(^TMP("SCMU",$J,"BAD")) + S SCERRAR=$NA(^TMP("SCMU",$J,"ERROR")) + S SCPTTP=$NA(^TMP("SCMU",$J,"PATIENT-POSITION")) + K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP + ; + N SCNT,SCNODE,SCPTX + ; + ; -- create patient-position array for team processing + IF SCMUTYPE="T" D PTTPLST^SCMCMU11(SCTEAM,SCDATE,SCPTTP) + ; + S SCNT=0 + F S SCNT=$O(@SCPTSEL@(SCNT)) Q:'SCNT D + . ;N SCDATE S SCDATE=2700101 ; -- use to force error/testing + . S SCPTX=$G(@SCPTINFO@(SCNT)) + . IF SCPTX="" Q + . IF SCMUTYPE="T" S SCOK=$$TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) + . ; + . IF SCMUTYPE="P" S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,SCPTX) + . ; + . ; -- if successful + . IF SCOK D + . . S @SCOKAR@(SCNT)="" + . . S SCUNCNT=SCUNCNT+1 + . . S SCASCNT=SCASCNT-1 + . ; + . ; -- if not sucessful + . ELSE D + . . S @SCBADAR@(SCNT)="" + ; + ; -- unlock top node + D UNLOCK(SCTOP) + ; + ; -- send results + D BULL^SCMCMU4 + ; + K @SCOKAR,@SCBADAR,@SCERRAR,@SCPTTP + K @SCPTSEL,@SCPTINFO + Q + ; + ; **** May want to eventually combine TMDIS & TPDIS tags **** + ; +TMDIS(SCDATE,SCTEAM,SCNT,SCPTX) ; -- team unassignment for patient + ; input: SCDATE := effective date + ; SCTEAM := ien of TEAM entry (404.51) + ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays + ; SCPTX := format defined by output of $$PTTM^SCAPMC2 + ; + N SCNODE,SCPOS,SCPOSI,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT + ; + S SCOK=1 + S SCERRS="SCERRLST" + ; + S DFN=+SCPTX + S SCIEN=+$P(SCPTX,U,3) + S SCNODE=$NA(^SCPT(404.42,SCIEN,0)) + S SCASDT=+$P(SCPTX,U,4) + S SCUNDT=+$P(SCPTX,U,5) + ; + ; -- unassign from positions first + S SCPOS=0 + F S SCPOS=$O(@SCPTTP@(DFN,SCPOS)) Q:'SCPOS D Q:'SCOK + . S SCOK=$$TPDIS(SCDATE,SCPOS,SCNT,$G(@SCPTTP@(DFN,SCPOS))) + ; + IF 'SCOK D + . S @SCERRAR@(SCNT,"TEAM",SCTEAM,1)="Team still assigned to patient." + . S @SCERRAR@(SCNT,"TEAM",SCTEAM,2)="Not able to unassign at least one position." + ; + IF SCOK D + . ; -- if assignment date is in future then delete + . IF SCASDT>DT,SCASDT>SCDATE D Q + . . N DA,DIK + . . S DA=SCIEN,DIK="^SCPT(404.42," + . . D LOCK(SCNODE) + . . D ^DIK + . . D UNLOCK(SCNODE) + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team assignment deleted." + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN + . . Q + . ; + . ; -- if assignment date is after effective date but before today + . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,1)=">>> Future team unassignment date was changed." + . . S @SCOKAR@(SCNT,"TEAM",SCTEAM,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" + ; + Q SCOK + ; +TPDIS(SCDATE,SCPOS,SCNT,SCPTX) ; -- position unassignment for patient + ; input: SCDATE := effective date + ; SCTEAM := ien of TEAM POSITION entry (404.57) + ; SCNT := entry in @SCPTINFO@ & @SCPTALL@ arrays + ; SCPTX := format defined by output of $$PTTP^SCAPMC2 + ; + N SCNODE,SCOK,SCERRS,DFN,SCIEN,SCASDT,SCUNDT + S SCASDT=+$P(SCPTX,U,4) + S SCUNDT=+$P(SCPTX,U,5) + ; + S SCOK=1 + S SCERRS="SCERRLST" + ; + S DFN=+SCPTX + S SCIEN=+$P(SCPTX,U,3) + S SCNODE=$NA(^SCPT(404.43,SCIEN,0)) + S SCASDT=+$P(SCPTX,U,4) + S SCUNDT=+$P(SCPTX,U,5) + ; + ; if assignment date is in future then delete + IF SCOK D + . ; -- if assignment date is in future then delete + . IF SCASDT>DT,SCASDT>SCDATE D Q + . . N DA,DIK + . . S DA=SCIEN,DIK="^SCPT(404.43," + . . D LOCK(SCNODE) + . . D ^DIK + . . D UNLOCK(SCNODE) + . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position assignment deleted." + . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Assignment Date: "_$$FMTE^XLFDT(SCASDT,"5Z")_" Entry#: "_SCIEN + . . Q + . ; + . ; -- if assignment date is after effective date but before today + . IF SCASDT>SCDATE,SCASDT
SCDATE,SCUNDT
SCDATE D + . . S @SCOKAR@(SCNT,"POS",SCPOS,1)=" >>> Future position unassignment date was changed." + . . S @SCOKAR@(SCNT,"POS",SCPOS,2)=" Old Date: "_$$FMTE^XLFDT(SCUNDT,"5Z")_" New Date: "_$$FMTE^XLFDT(SCDATE,"5Z")_" Entry#: "_SCIEN_")" + . . Q + ; + IF SCOK D + . S @SCOKAR@(SCNT,"CLINIC",SCPOS,1)=$$CLDIS(SCPOS) + . Q + ; +TPDISQ Q SCOK + ; +CLDIS(SCPOS) ; -- discharge from clinic + N SCPOS0,SCCLN,SCREA,SCRET + S SCRET="" + ; + ; -- if user did not request clinic discharge, quit + IF '$G(SCTPDIS(+SCPOS)) G CLDISQ + ; + S SCPOS0=$G(^SCTM(404.57,SCPOS,0)) + S SCCLN=$P(SCPOS0,U,9) + IF SCCLN D + . S SCREA="Team position mass discharge" + . S SCRET=$$EN^SCMCMU3(DFN,SCCLN,SCDATE,SCREA) + . Q + ELSE D + . S SCRET="0^No clinic assignment to position" + . Q + ; +CLDISQ Q SCRET + ; +LOCK(NODE) ; -- lock node + F L +@NODE:5 IF $T Q + Q + ; +UNLOCK(NODE) ; -- unlock node + L -@NODE + Q + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCQK1.m (revision 623) @@ -1,268 +1,268 @@ -SCMCQK1 ;ALBOI/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge;11/07/02 - ;;5.3;Scheduling;**148,177,231,264,436,297,446,524**;AUG 13, 1993;Build 29 - ; - ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER -UNTP ;unassign patient from pc prac position - I '$G(SCTP) W !,"No position defined" Q - N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS - S OK=0 - W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" - S SCDISCH=$$DATE("D") - G:SCDISCH<1 QTUNTP - G:'$$CONFIRM() QTUNTP - S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) ; og/sd/524 - G:OK'>0 QTUNTP - S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) - I SCCL D DISCL -QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") - Q -ENRCL ; - N SCRESTA,SCREST,SCCLNM,SCTM - N SCCL - F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D - .Q:$$ACTCL(DFN,SCCL) - .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic." - .;SCRESTA = Array of pt's teams causing restricted consults - .N SCRESTA - .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") - .I SCREST D - ..N SCTM - ..S SCCLNM=Y - ..W !,?5,"Patient has restricted consults due to team assignment(s):" - ..S SCTM=0 - ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) - .I SCREST&'$G(SCOKCONS) D G QTECL - ..W !,?5,"This patient may only be enrolled in clinics via" - ..W !,?15,"Edit Clinic Enrollment Data option" - .W !,"Do you wish to enroll the patient from this clinic on " - .S Y=SCASSDT X ^DD("DD") W Y,"?" - .I $$YESNO() D - ..W !,"Clinic Enrollment" - ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made" - ..E W "NOT made" -QTECL Q -DISCL ; - N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D - .Q:'$$ACTCL(DFN,SCCL) - .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic." - .W !,"Do you wish to discharge the patient from this clinic on " - .S Y=SCDISCH X ^DD("DD") W Y,"?" - .Q:'$$YESNO() - .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL - .N DFN D ^SDCD -QTDCL Q -UNTM ; - ;assign patient from pc team (and pc position if possible) - N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 - S OK=0 - W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" - W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" - S SCDISCH=$$DATE("D") - G:SCDISCH<1 QTUNTM - G:'$$CONFIRM() QTUNTM - IF 'SCTPSTAT D G:OK2'>0 QTUNTM - .W !,"PC assignment unassigned." - .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) - .IF OK2>0 D - ..W "made." - ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) - ..D:SCCL DISCL - S OK3=$$ALLPOS() - IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D - .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) - ELSE D - .W !,"Future/Current Patient-Position Assignment exists" -QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") - Q -ALLPOS() ;unassign all patient-positions for team - ;not stand-alone - needs dfn,sctm - ;return 1=No positions left assigned|0=At least 1 position assigned - N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2 - S SCDT1("BEGIN")=SCDISCH+1 - S SCDT1("END")=3990101 - S SCDT1("INCL")=0 ;anytime from now to future - S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR) - S (SCTP,SCCNT)=0 - W !,"Checking for other position assignments to team..." - F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D - .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1) - .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0)) - .S SCNODE=SCPTTPX(SCLOC) - .S SCPTTP2(SCTP)="" - .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8) - .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D - ..W !,?5,"Unassignment date already exists or unassignment after assignment date" - ..W !,?15,"- Correct via PCMM GUI" - ..S OK=0 - W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)" - G:'OK!('SCCNT) QTALL - W !!,"About to unassign the above patient-position assignments" - IF '$$CONFIRM S OK=0 G QTALL - S SCTP=0 - F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK - .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) - .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI" -QTALL Q OK -ASTM ;assign patient to PC team - N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS - S OK=0 - W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team" - I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" - S DIC="^SCTM(404.51," - S DIC(0)="AEMQZ" - S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))" - ;select from active teams that can be PC Teams - D ^DIC - G:Y<1 QTASTM - S SCTM=+Y - ;The following logic to present warning message added per SD*5.3*436 - I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM - .S SCFLAG=0 - .W !!,"This team is closed to further patient assignments. While you are" - .W !,"not currently prevented from assigning this patient, you may want to" - .W !,"check before continuing." - .Q:'$$YESNO1() ; new function call per SD*5.3*436 - .Q:'$$CONFIRM() - .S SCFLAG=1 W ! - S SCASSDT=$$DATE("A") - G:SCASSDT<1 QTASTM - S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) - S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) - I SCTMCT'0 -YESNO1() ; added per SD*5.3*436 - N DIR,X,Y - S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?" - S DIR("B")="NO" - D ^DIR - Q Y>0 -YESNO2() ; - N DIR,X,Y - S DIR(0)="Y",DIR("B")="NO" - S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" - D ^DIR - Q Y>0 -CONFIRM() ;confirmation call - N DIR,X,Y - S DIR("A")="Are you sure (Yes/No)" - S DIR(0)="Y" - D ^DIR - Q +Y=1 -SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE - N DIR,X,Y - W !,"Choose way to select PC POSITION Assignment: " - S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" - S DIR("B")=1 - D ^DIR - Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") -DATE(TYPE) ;return date type=A or D - N DIR,X,Y - S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " - S DIR(0)="DA^::EXP" - S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") - X ^DD("DD") - S DIR("B")=Y - D ^DIR - Q Y -ACTCL(DFN,SCCL) ;is patient enrolled in clinic? - N SCXX - S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1) - Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1) -PRACSCR(SC40452) ;screen for for file 404.52 - N SCP,SCNODE,OK - S SCP=$G(^SCTM(404.52,SC40452,0)) - S OK=0 - G:'SCP QTPP - S SCNODE=$G(^SCTM(404.57,+SCP,0)) - S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) -QTPP Q OK -POSSCR(SCTP) ;screen for file 404.57 - N SCNODE - S SCNODE=$G(^SCTM(404.57,SCTP,0)) - Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) - Q -WAITYN() ; - N %,OK,Y - I SCTMCT1,1:1) Q 0 - N DIR,X,Y - S DIR(0)="Y",DIR("B")="NO" - S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?" - D ^DIR - I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List" - Q Y>0 -SC(DFN) ;Is patient 50 to 100% - D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49 +SCMCQK1 ;ALB/REW - Single Pt Tm/Pt Tm Pos Assign and Discharge ; 07 Oct 2002 12:10 PM ; Compiled April 12, 2007 10:03:59 + ;;5.3;Scheduling;**148,177,231,264,436,297,446**;AUG 13, 1993;Build 77 + ; + ;04/25/2006 SD*5.3*446 INTER-FACILITY TRANSFER +UNTP ;unassign patient from pc prac position + I '$G(SCTP) W !,"No position defined" Q + N OK,SCER,SCCL,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS + S OK=0 + W !,"About to Unassign "_$$NAME(DFN)_" from: ",!,?8,$$POSITION(SCTP)_" position ["_$P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_"]" + S SCDISCH=$$DATE("D") + G:SCDISCH<1 QTUNTP + G:'$$CONFIRM() QTUNTP + S OK=1 ;$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) + G:OK'>0 QTUNTP + S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9) + I SCCL D DISCL +QTUNTP W !,"Position Unassignment "_$S(OK:"made.",1:"NOT made.") + Q +ENRCL ; + N SCRESTA,SCREST,SCCLNM,SCTM + N SCCL + F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D + .Q:$$ACTCL(DFN,SCCL) + .W !!!,"The "_$$POSITION(SCTP)_" is associated with the ",$$CLINIC(SCCL)_" clinic." + .;SCRESTA = Array of pt's teams causing restricted consults + .N SCRESTA + .S SCREST=$$RESTPT^SCAPMCU4(DFN,DT,"SCRESTA") + .I SCREST D + ..N SCTM + ..S SCCLNM=Y + ..W !,?5,"Patient has restricted consults due to team assignment(s):" + ..S SCTM=0 + ..F S SCTM=$O(SCRESTA(SCTM)) Q:'SCTM W !,?10,SCRESTA(SCTM) + .I SCREST&'$G(SCOKCONS) D G QTECL + ..W !,?5,"This patient may only be enrolled in clinics via" + ..W !,?15,"Edit Clinic Enrollment Data option" + .W !,"Do you wish to enroll the patient from this clinic on " + .S Y=SCASSDT X ^DD("DD") W Y,"?" + .I $$YESNO() D + ..W !,"Clinic Enrollment" + ..I $$ACPTCL^SCAPMC18(DFN,SCCL,,SCASSDT,"SCENER") W " made" + ..E W "NOT made" +QTECL Q +DISCL ; + N SCCL F SCCL=0:0 S SCCL=$O(^SCTM(404.57,+$G(SCTP),5,SCCL)) Q:'SCCL D + .Q:'$$ACTCL(DFN,SCCL) + .W !,$$NAME(DFN)," is enrolled in the associated "_$$CLINIC(SCCL)_" clinic." + .W !,"Do you wish to discharge the patient from this clinic on " + .S Y=SCDISCH X ^DD("DD") W Y,"?" + .Q:'$$YESNO() + .N SDFN,SDCLN S SDFN=DFN,SDCLN=SCCL + .N DFN D ^SDCD +QTDCL Q +UNTM ; + ;assign patient from pc team (and pc position if possible) + N OK,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS,OK2,OK3 + S OK=0 + W !!,"About to Unassign "_$$NAME(DFN)_" from "_$$TEAMNM(SCTM)_" team" + W:'SCTPSTAT !,?5,"AND from "_$$POSITION(SCTP)_" position ["_$$WRITETP^SCMCDD1(SCTP)_"]" + S SCDISCH=$$DATE("D") + G:SCDISCH<1 QTUNTM + G:'$$CONFIRM() QTUNTM + IF 'SCTPSTAT D G:OK2'>0 QTUNTM + .W !,"PC assignment unassigned." + .S OK2=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) + .IF OK2>0 D + ..W "made." + ..S SCCL=$P(^SCTM(404.57,SCTP,0),U,9) + ..D:SCCL DISCL + S OK3=$$ALLPOS() + IF $$OKINPTTM^SCMCTMU2(DFN,SCTM,SCDISCH) D + .S OK=$$INPTSCTM^SCAPMC7(DFN,SCTM,SCDISCH,.SCER) + ELSE D + .W !,"Future/Current Patient-Position Assignment exists" +QTUNTM W !,"Team Unassignment "_$S(OK:"made",1:"NOT made.") + Q +ALLPOS() ;unassign all patient-positions for team + ;not stand-alone - needs dfn,sctm + ;return 1=No positions left assigned|0=At least 1 position assigned + N OK,SCDT1,SCPTTPX,SCERRR,SCTP,SCCNT,SCPTTPI,SCLOC,SCNODE,SCPTTP2 + S SCDT1("BEGIN")=SCDISCH+1 + S SCDT1("END")=3990101 + S SCDT1("INCL")=0 ;anytime from now to future + S OK=$$TPPT^SCAPMC23(DFN,"SCDT1",,,,,,"SCPTTPX",.SCERRR) + S (SCTP,SCCNT)=0 + W !,"Checking for other position assignments to team..." + F S SCTP=$O(SCPTTPX("SCTP",SCTM,SCTP)) Q:'SCTP S SCCNT=SCCNT+1 D + .S SCPTTPI=$O(SCPTTPX("SCTP",SCTM,SCTP,9999999),-1) + .S SCLOC=$O(SCPTTPX("SCTP",SCTM,SCTP,SCPTTPI,0)) + .S SCNODE=SCPTTPX(SCLOC) + .S SCPTTP2(SCTP)="" + .W !,?3,$P(SCNODE,U,2)," ",$P(SCNODE,U,8) + .IF $P(SCNODE,U,6)!(SCDISCH'>$P(SCNODE,U,5)) D + ..W !,?5,"Unassignment date already exists or unassignment after assignment date" + ..W !,?15,"- Correct via PCMM GUI" + ..S OK=0 + W !,?5,$S(SCCNT:SCCNT,1:"No")_" current/future position assignment(s)" + G:'OK!('SCCNT) QTALL + W !!,"About to unassign the above patient-position assignments" + IF '$$CONFIRM S OK=0 G QTALL + S SCTP=0 + F S SCTP=$O(SCPTTP2(SCTP)) Q:'SCTP D Q:'OK + .S OK=$$INPTSCTP^SCAPMC22(DFN,SCTP,SCDISCH,.SCER) + .W:'OK !,?10,"Problem with unassignment, correct via PCMM GUI" +QTALL Q OK +ASTM ;assign patient to PC team + N DIC,Y,OK,SCTM,SCTMFLDS,SCER,SCBEGIN,SCN,SCLIST,SCEND,SCINCL,SCLSEQ,SCDATES,SCDTS + S OK=0 + W !!,"About to Assign "_$$NAME(DFN)_" to a primary care team" + I $$SC(DFN) W !!,"********** This patient is 50 percent or greater service-connected ************" + S DIC="^SCTM(404.51," + S DIC(0)="AEMQZ" + S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))" + ;select from active teams that can be PC Teams + D ^DIC + G:Y<1 QTASTM + S SCTM=+Y + ;The following logic to present warning message added per SD*5.3*436 + I $P($G(^SCTM(404.51,SCTM,0)),U,10) D G:'SCFLAG QTASTM + .S SCFLAG=0 + .W !!,"This team is closed to further patient assignments. While you are" + .W !,"not currently prevented from assigning this patient, you may want to" + .W !,"check before continuing." + .Q:'$$YESNO1() ; new function call per SD*5.3*436 + .Q:'$$CONFIRM() + .S SCFLAG=1 W ! + S SCASSDT=$$DATE("A") + G:SCASSDT<1 QTASTM + S SCTMCT=$$TEAMCNT^SCAPMCU1(SCTM) + S SCTMMAX=$P($$GETEAM^SCAPMCU3(SCTM),"^",8) + I SCTMCT'0 +YESNO1() ; added per SD*5.3*436 + N DIR,X,Y + S DIR(0)="Y",DIR("A")="Do you wish to assign this patient now (Yes/No)?" + S DIR("B")="NO" + D ^DIR + Q Y>0 +YESNO2() ; + N DIR,X,Y + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Do you wish to continue with the assignment (Yes/No)?" + D ^DIR + Q Y>0 +CONFIRM() ;confirmation call + N DIR,X,Y + S DIR("A")="Are you sure (Yes/No)" + S DIR(0)="Y" + D ^DIR + Q +Y=1 +SELPOS() ;return way to select position: 1=PRACT,2=POSIT,3=NONE + N DIR,X,Y + W !,"Choose way to select PC POSITION Assignment: " + S DIR(0)="SO^0:NONE;1:BY PRACTITIONER ASSIGNMENT;2:BY POSITION ASSIGNMENT" + S DIR("B")=1 + D ^DIR + Q $S(Y'>0:"",+Y=1:"PRACT",1:"POSIT") +DATE(TYPE) ;return date type=A or D + N DIR,X,Y + S DIR("A")=$S(TYPE="A":"Assignment",1:"Unassignment")_" date: " + S DIR(0)="DA^::EXP" + S Y=$S($D(SCDISCH):SCDISCH,$D(SCASSDT):SCASSDT,(TYPE="A"):"TODAY",1:"TODAY-1") + X ^DD("DD") + S DIR("B")=Y + D ^DIR + Q Y +ACTCL(DFN,SCCL) ;is patient enrolled in clinic? + N SCXX + S SCXX=$O(^DPT(DFN,"DE","B",SCCL,9999),-1) + Q $S('SCXX:0,($P(^DPT(DFN,"DE",+SCXX,0),U,2)="I"):0,1:1) +PRACSCR(SC40452) ;screen for for file 404.52 + N SCP,SCNODE,OK + S SCP=$G(^SCTM(404.52,SC40452,0)) + S OK=0 + G:'SCP QTPP + S SCNODE=$G(^SCTM(404.57,+SCP,0)) + S OK=$S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($O(^SCTM(404.52,"AIDT",+SCP,1,""))'=-$P(SCP,U,2)):0,($O(^SCTM(404.52,"AIDT",+SCP,0,-$P(SCP,U,2)),-1)):0,($$ACTTP^SCMCTPU(+SCP)>0):1,1:0) +QTPP Q OK +POSSCR(SCTP) ;screen for file 404.57 + N SCNODE + S SCNODE=$G(^SCTM(404.57,SCTP,0)) + Q $S($P(SCNODE,U,2)'=SCTM:0,'$P(SCNODE,U,4):0,($$ACTTP^SCMCTPU(SCTP)>0):1,1:0) + Q +WAITYN() ; + N %,OK,Y + I SCTMCT1,1:1) Q 0 + N DIR,X,Y + S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Do you wish to place the patient on the wait list (Yes/No)?" + D ^DIR + I Y=1 S Y=$$WAITS^SCMCWAIT(DFN,SCTM,$G(SCTP),$G(SC)) I Y>0 W !,"Patient Placed on Wait List" + Q Y>0 +SC(DFN) ;Is patient 50 to 100% + D ELIG^VADPT Q $P($G(VAEL(3)),U,2)>49 Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK1.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK1.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK1.m (revision 623) @@ -1,246 +1,244 @@ -SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003 9:36 AM ; 10/24/07 12:24pm ; Compiled January 25, 2008 12:11:43 ; Compiled March 26, 2008 22:27:26 - ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21 - Q -INACTIVE ; - ;Flag patients - N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD S CNT=0 - D DT^DICRW - N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q - I SDDT'>0 D DT^DICRW S SDDT=DT - S %DT="",X="T-11M" D ^%DT S STDD=+Y - S A="^SCPT(404.43,""ADFN""",L="""""" - S Q=A_")" - F S Q=$Q(@Q) Q:Q'[A D - .S ENTRY=+$P(Q,",",6) - .S ZERO=$G(^SCPT(404.43,+ENTRY,0)) - .I $P(ZERO,U,15) Q - .S POS=+$P(ZERO,U,2) - .I $P(ZERO,U,4) Q ;UNASS - .I '$P(ZERO,U,5) Q ;Not PC - .I $P(ZERO,U,3)>STDD Q ;<11 months - .I $P(ZERO,U,17) Q ;React - .;get preceptor - .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) - .S DFN=$P(Q,",",3) - .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN) - .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U) - .N STDT S %DT="",X="T-12M" D ^%DT S STDT=+Y - .;N-new or E-est - .N NEW - .I $P(ZERO,U,3)$P(SCPRO(PRO,SDX),U,2)) S SEEN=1 - Q -DIS ;disch - N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0)) - I $P(ZERO,U,4) Q - D DIS2^SCMCTSK7 - Q -CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic - S DATA(0)=-1 - Q -EXTEND(DATA,SCTEAM) ;to inact. in next 60 days - ;IEN^POSITION^PATIENT^EXTENDED^REASON - K DATA,SCDATA,SDDATA - N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="" - D DT^DICRW - N SD1 S SDDT="" F SD1=DT,DT-1 I $D(^XTMP("SCMCTSK2-"_SD1,$J,"START")) S SDDT=SD1 Q - I SDDT'>0 D DT^DICRW S SDDT=DT - S X="T-9M" D ^%DT S STDT=Y - S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 - S POSA="" - S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q - F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D Q:CNT>100 - .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS Q:CNT>100 - I CNT>100 S DATA(1)="TOO MANY" Q -EX1 S A="SDDATA",CNT=1 F S A=$Q(@A) Q:A="" D - .S B=@A - .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) - .S CNT=CNT+1 - Q -POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Position inact - I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC - ;patients for position - K ^TMP("SC TMP LIST",$J) - S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) - S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D - .N J I $P(SCDATA,U,4)>STDT Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q - .S DFN=+SCDATA - .D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN - .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 - K @SCLIST - Q -FILE(RES,DATA) ;File data on FTEE - N I - F I=1:1 Q:'$D(DATA(I)) D - .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]") - .S ZERO=$G(^SCPT(404.43,+DATA(I),0)) - .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q - .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6) - .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50) - .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ)) - I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR") - Q -SCREEN ;Active assign. screen - N A S A=$G(^SCTM(404.52,D0,0)) - N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q - I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC - I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position - I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))1 - N A S A=$G(^SCTM(404.52,+PAIEN,0)),FTEE=$$SUM(+$P(PAIEN,U,3),+A) - S DATA=0 - S DATA=FTEE+$P(PAIEN,U,2) - Q -SORT(DIPA,SDD) ;sort tmpl - N DIC - S DIC=4,DIC(0)="ZME" - S DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" - S DIR("A")="Start with Institution",DIR("B")="FIRST",DIR(0)="F" D ^DIR - I X="FIRST" S DIPA("SI")="",DIPA("EI")="zzz",SDD=1 Q - D ^DIC I Y<0 S DIPA("SI")=X S SDD=X Q:SDD[U D - .S DIR("A")="Go to Institutiton",DIR("B")="LAST" S DIR(0)="F" D ^DIR - .I X="LAST" S DIPA("EI")="zzz" - I Y>0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: " - D ^DIC - I Y>0 S DIPA("EI")=$P(Y(0),U) - I Y<0 S DIPA("EI")=X S SDD=X Q:SDD[U - S SDD=1 Q -FTEERPT ;FTEE REPORT - D FTERPT^SCMCTSK6 Q - Q -POSCHK(DATA,INFO) ; - N PCLASS - ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN - I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q - I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q - I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q - S DATA=0 - I ('INFO)!('$P(INFO,U,2)) Q - ;Is provider role acceptable? - S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J="" - I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))0 - ;event filer for 1 patient - S SCDFN=+Y W !,SCDFN -SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)" - ;quit if no PC assign - Q:'$D(@SC1) - S SCADT=0 - F S SCADT=$O(@SC1@(SCADT)) Q:SCADT="" D - .S SCTP=0 - .F S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP D - ..; quit if team position does not exist - ..Q:'$D(^SCTM(404.57,SCTP,0)) - ..S SCPAI=0 - ..F S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI D - ...S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4) - ...;quit if not active within date range - ...Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1 - ...N SCVAR S SCVAR=SCPAI_";SCPT(404.43," - ...;add to HL7 event file - ...Q:$D(^SCPT(404.48,"AACXMIT",SCVAR)) - ...Q:$$CHECK^SCMCHLB1(SCVAR)'=1 - ...D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP) - Q -PRSEED ;seed practitioner - N AH,SC177 - S SC177=$$PDAT^SCMCGU("SD*5.3*177") - I +SC177=0 D Q - . S SC2=" No SD*5.3*177 Installation Date." - . D MSG^SCMCCV6(SC1,SC2) - S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0 - S SCPROV=+Y - F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH S TP=+$G(^SCTM(404.52,+AH,0)) D - . Q:$D(SCTP(TP)) - . S SCTP(TP)=1 - . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1 - . Q:'$P($G(^SCTM(404.57,TP,0)),U,4) - . S SCVAR=AH_";SCTM(404.52," - . ;Quit if an event entry already exists - . N QUIT,I S QUIT=0 - . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q - . Q:QUIT - . D ADD^SCMCHLE("NOW",SCVAR,,AH,1) - Q -INCON ;inconsistent PC assignments - N POS - D INCON^SCMCTSK3 - Q -INCONR ;inconsistent report - N BY - K ^TMP("SCMCTSK",$J) - S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1" - D EN1^DIP - Q -INACTDT(PA) ;Scheduled inactivation date. - D INACT^SCMCTSK3 Q -IU(DFN) ;is patient inactivity unassigned - Q $$IU^SCMCTSK3(DFN) - N I,A,B,DATA +SCMCTSK1 ;ALB/JDS - PCMM Inactivations; 18 Apr 2003 9:36 AM ; 10/24/07 12:24pm + ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6 + Q +INACTIVE ;run every night to determine if patient can be inactivated from + ;team + ;Inactivation happens for patients without activity for 24 months + N I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q S CNT=0 + D DT^DICRW S %DT="",X="T-11M" D ^%DT S STDT=Y + S SC297=$$PDAT^SCMCGU("SD*5.3*297"),X1=DT,X2=SC297 D D^%DTC S SC297=X + S X="T-"_$S(SC297>330:"11M",1:"23M") D ^%DT S TYDT=+Y + S A="^SCPT(404.43,""ADFN""",L="""""" + S Q=A_")" + F S Q=$Q(@Q) Q:Q'[A D + .S ENTRY=+$P(Q,",",6) + .S ZERO=$G(^SCPT(404.43,+ENTRY,0)) + .S POS=+$P(ZERO,U,2) + .S TEAM=$P(Q,",",4) + .;I $P($G(^SCTM(404.51,+TEAM,0)),U,16) Q ;no automatic for this team + .;I $G(^DPT(DFN,.35)) D DIS Q ;Patient is deceased + .I $P(ZERO,U,3)>STDT Q ;Later + .I $P(ZERO,U,17) Q ;Already reactivated + .;get preceptor position + .S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) + .;see if provider changed + .I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) Q + .I $P(ZERO,U,4) Q ;Already unassigned + .I '$P(ZERO,U,5) Q ;Not primary care + .;I $P(ZERO,U,16) Q ;No Automatic unassign + .;Check if any activity + .S DFN=$P(Q,",",3) + .I $G(XPDIDTOT),('(DFN#5)) D UPDATE^XPDID(DFN) + .S TEAM=$P(Q,",",4),TEAMNM=$P($G(^SCTM(404.51,+TEAM,0)),U) + .D SEEN Q:SEEN + .I '$P(ZERO,U,15) D + ..S DIE="^SCPT(404.43,",DR=".15////"_DT,DA=ENTRY D ^DIE + ..S TPZ=$G(^SCTM(404.57,+POS,2)) + ..I "TP"[$P(TPZ,U,10) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)="" + ..I $P(TPZ,U,9),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)="" + Q +SEEN ;was patient seen + S SEEN=0 + N SCPRO,I,PRECP,PRO + N X,SCPRDTS,SCPR + ;get list of providers for this position + S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)="" + S SCPRDTS("BEGIN")=TYDT + S SCPRDTS("END")=DT + S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR") + F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="" + S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)="" + F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN + .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN + ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q + ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN + ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ + ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q + Q +DIS ;discharge + N ZERO S ZERO=$G(^SCPT(404.43,+ENTRY,0)) + I $P(ZERO,U,4) Q ;Already discharged + D DIS2^SCMCTSK7 + Q +EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days + ;IEN^POSITION^PATIENT^EXTENDED^REASON + K DATA,SCDATA,SDDATA + N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),DATA(1)="" + D DT^DICRW S X="T-9M" D ^%DT S STDT=Y + S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 + S POSA="" + S POS=+$P(SCTEAM,U,2) I POS D POS,EX1 Q + F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D Q:CNT>100 + .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS Q:CNT>100 + I CNT>100 S DATA(1)="TOO MANY" Q +EX1 S A="SDDATA",CNT=1 F S A=$Q(@A) Q:A="" D + .S B=@A + .S DATA(CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",2),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) + .S CNT=CNT+1 + Q +POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position + I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC + ;get patients for this position + K ^TMP("SC TMP LIST",$J) + S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) + S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D + .N J I $P(SCDATA,U,4)>STDT Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q + .S DFN=+SCDATA + .D SEEN Q:SEEN + .S SDDATA($P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 + K @SCLIST + Q +FILE(RES,DATA) ;File data on FTEE + N I + F I=1:1 Q:'$D(DATA(I)) D + .S $P(DATA(I),U,7)=$TR($P(DATA(I),U,7),"[]") + .S ZERO=$G(^SCPT(404.43,+DATA(I),0)) + .I $P(ZERO,U,13)=$P(DATA(I),U,6) I $P(ZERO,U,14)=$P(DATA(I),U,7) Q + .S FLDA(404.43,(+DATA(I))_",",.13)=$P(DATA(I),U,6) + .S FLDA(404.43,(+DATA(I))_",",.14)=$E($P(DATA(I),U,7),1,50) + .S FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$G(DUZ)) + I $O(FLDA(0)) D FILE^DIE("E","FLDA","ERR") + Q +SCREEN ;Screen for active assignments + N A S A=$G(^SCTM(404.52,D0,0)) + N J S J=-(DT+1),J=$O(^SCTM(404.52,"AIDT",+A,1,J)) I J="" S X=0 Q + I '$P($G(^SCTM(404.57,+A,0)),U,4) Q ;Not PC + I '$$DATES^SCAPMCU1(404.59,+A) Q ;Not an active position + I $O(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))0 S DIPA("SI")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Institution: " + D ^DIC + I Y>0 S DIPA("EI")=$P(Y(0),U) + I Y<0 S DIPA("EI")=X Q:X[U + S X=1 Q +FTEERPT ;FTEE REPORT + D FTERPT^SCMCTSK6 Q + Q +POSCHK(DATA,INFO) ; + N PCLASS + ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN + I '$P(INFO,U,3) S DATA="1^Role Must be Entered" Q + I $P(INFO,U,2) I '$P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3) S DATA="1^This Role cannot provide Primary Care" Q + I $P(INFO,U,2),($P($G(^SD(403.46,+$P(INFO,U,3),0)),U,3)=2) I '$$DATES^SCAPMCU1(404.53,+INFO) S DATA="1^This Role cannot provide Primary Care unless Precepted" Q + S DATA=0 + I ('INFO)!('$P(INFO,U,2)) Q + ;Check if provider can be in this role. + S J=-(DT+1) S J=$O(^SCTM(404.52,"AIDT",+INFO,1,J)) Q:J="" + I $O(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))0 + ;event filer for 1 patient + S SCDFN=+Y W !,SCDFN +SCDFN S SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)" + ; + ;quit if no PC assignments + Q:'$D(@SC1) + S SCADT=0 + F S SCADT=$O(@SC1@(SCADT)) Q:SCADT="" D + . S SCTP=0 + . F S SCTP=$O(@SC1@(SCADT,SCTP)) Q:'SCTP D + . . ; + . . ; quit if team position does not exist + . . Q:'$D(^SCTM(404.57,SCTP,0)) + . . S SCPAI=0 + . . F S SCPAI=$O(@SC1@(SCADT,SCTP,SCPAI)) Q:'SCPAI D + . . . S SCDDT=$P($G(^SCPT(404.43,SCPAI,0)),U,4) + . . . ; + . . . ; quit if not active within date range + . . . Q:$$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1 + . . . N SCVAR S SCVAR=SCPAI_";SCPT(404.43," + . . . ; + . . . ; add to HL7 event file + . . . Q:$D(^SCPT(404.48,"AACXMIT",SCVAR)) + . . . Q:$$CHECK^SCMCHLB1(SCVAR)'=1 + . . . D ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP) + Q +PRSEED ;seed practitioner + N AH,SC177 + S SC177=$$PDAT^SCMCGU("SD*5.3*177") + I +SC177=0 D Q + . S SC2=" Unable to obtain SD*5.3*177 Installation Date." + . D MSG^SCMCCV6(SC1,SC2) + . Q + S DIC=200,DIC(0)="MEQA",DIC("A")="Select Provider: " D ^DIC Q:Y'>0 + S SCPROV=+Y + F AH=0:0 S AH=$O(^SCTM(404.52,"C",SCPROV,AH)) Q:'AH S TP=+$G(^SCTM(404.52,+AH,0)) D + . Q:$D(SCTP(TP)) + . S SCTP(TP)=1 + . F SCDFN=0:0 S SCDFN=$O(^SCPT(404.43,"ADFN",SCDFN)) Q:'SCDFN I $D(^(SCDFN,TP)) I '$D(SCU(SCDFN)) D SCDFN S SCU(SCDFN)=1 + . Q:'$P($G(^SCTM(404.57,TP,0)),U,4) + . S SCVAR=AH_";SCTM(404.52," + . ;Quit if an event entry already exists + . N QUIT,I S QUIT=0 + . F I=0:0 S I=$O(^SCPT(404.48,"AACXMIT",SCVAR,I)) Q:'I I $P($G(^SCPT(404.48,I,0)),U,8) S QUIT=1 Q + . Q:QUIT + . D ADD^SCMCHLE("NOW",SCVAR,,AH,1) + Q +INCON ;get list of incositent provider assignments + N POS + D INCON^SCMCTSK3 + Q +INCONR ;inconsistent report + N BY + K ^TMP("SCMCTSK",$J) + S DIC="^SCTM(404.57,",(FLDS,BY)="[SCMC INCONSISTENT]",DIOBEG="D INCON^SCMCTSK1" + D EN1^DIP + Q +CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic + S DATA(0)=-1 + N I + N POS,DFN S DFN=+$G(INFO) Q:'DFN S POS=+$P($G(INFO),U,2) Q:'POS + F I=0:0 S I=$O(^SCTM(404.57,POS,5,I)) Q:'I D CECHK^SCRPPAT2(I,.CNAME,DFN) I $L(CNAME) S:DATA(0)=-1 DATA(0)="" S DATA(0)=DATA(0)_CNAME_"." + I DATA(0)'=-1 S DATA(0)=$E(DATA(0),1,$L(DATA(0))-2) + Q +INACTDT(PA) ;Scheduled inactivation date. + D INACT^SCMCTSK3 Q +IU(DFN) ;is patient inactivity unassigned + Q $$IU^SCMCTSK3(DFN) + N I,A,B,DATA Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK2.m (revision 623) @@ -1,245 +1,238 @@ -SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003 9:36 AM ; 10/24/07 12:23pm ; Compiled November 21, 2007 13:32:47 ; Compiled March 17, 2008 15:27:15 - ;;5.3;Scheduling;**297,498,527,499**;AUG 13, 1993;Build 21 - Q -NIGHT ; - N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN,SDDT - D DT^DICRW S SDDT=$P($G(^XTMP("SCMCTSK2-"_DT,0)),U,2) - I SDDT="" S SDDT=DT - S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA12 months since flagging, not NEW, E-stbl) - ..N NEW - ..S NEW=0 S X1=DATE,X2=SDASS D ^%DTC I X<365 S NEW=1 - ..I NEW S %DT="",X="T-12M" D ^%DT S STDT=+Y D - ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X - ..I 'NEW S %DT="",X="T-24M" D ^%DT S STDT=+Y D - ...S X1=STDT,X2=-7 D C^%DTC S TYDT=X - ..; - ..I $P(ZERO,U,17) D UNFLG Q ;react. - ..;get prec - ..;S %DT="",X="T-12M" D ^%DT S STDT=+Y - ..;S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) - ..I '$P(ZERO,U,5) D UNFLG Q ;Not PC - ..D SEEN^SCMCTSK1(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) - ..;S PC=$$GET^XUA4A72(+PROV) - ..I SEEN D UNFLG Q - ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>SDDT Q ;do not inactivate yet; extended - ..I ('NOINAC)&(SDDT'SDDT D - .D PRINAC - .N FLDA - .S FLDA(404.44,"1,",19)="" - .D FILE^DIE("I","FLDA","ERR") - D BULL K ^TMP($J,"SCMCTSK2") - Q -UNFLG ;Unflagging - N DR,DIE,DA - S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE - Q -PRFLAG ;flag incorrect provider pos - N POS - ;prov inact. has run once - I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q - D PRFLAG^SCMCTSK3 - Q -PRINAC ;inact. flagged providers - N I,II - ;Prov inact. run already - I $G(SDDT)="" S SDDT=DT - S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=SDDT Q - F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D - .;I $P(ZERO,U,10)>$G(ENDT) Q ;not time yet - .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q ;inactivated - .;Check valid criteria - .S POS=+ZERO - .S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT) - .S PC=$$GET^XUA4A72(+PROV) - .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE ;remove flag - .S ZERO1=$G(^SCTM(404.57,POS,0)) - .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D - ..;inactivation - ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_SDDT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1" - ..S DIC(0)="LM" D ^DIC - ;only run inact. once - S $P(^SCTM(404.44,1,1),U,11)=SDDT - Q -FUTAPP(DFN) ;print future appts - N TAB,SCDT0 S TAB=$X - I $G(SDDT)="" S SDDT=DT - S SCDT=SDDT+.24 - F S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT D - . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2)) - . S CLIEN=$P(SCDT0,"^") Q:'CLIEN - . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10) - Q -GETASC(DATA,ENTRY) ;get assoc. clinics - N I,CNT S CNT=0 - F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U) - Q -SETASC(RESULT,DATA) ;set assoc. clinics - D SETASC^SCMCTSK7(.RESULT,DATA) Q -MSG(SCTP,DFN) ;send inact. message - ;given valid positions get current practitioners - S SCLIST="SCL" - I $G(SDDT)="" S SDDT=DT - I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D - .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR) - .;if preceptor notice turned on for message type - I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D - .S SCX=+$$OKPREC2^SCMCLK(SCTP,SDDT) - .;if preceptor duz returned, add to array - .I SCX S @SCLIST@("SCPR",SCX)="" - N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I S XMY(I)="" - S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from PC team position "_$P($G(^SCTM(404.57,SCTP,0)),U) - S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD - Q -BULL ;EOM Bulletin - N DISUPNO,BY,DHIT,HEAD - S DISUPNO=1,L=0 - S XMSUB="Patients Scheduled for Inactivation from PC Panel" - S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J) - S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" - S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0 - S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP - S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days" - D LINES(1) - D ^XMD - D PRMAIL^SCMCTSK5(1) - F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI D - .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J) - .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI) - .S XMSUB="Patients Scheduled for Inactivation from PC Panel" - .S XMTEXT="^TMP(""SCMCTXT"",$J," - S DISUPNO=1 - K ^TMP("SCMC",$J),^TMP("SCMCTXT") - I $G(NOINAC) K ^TMP($J,"SCMCTSK2") Q ; SD/499 - S XMSUB="Patients With Extended PCMM Inactivation Dates" - S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - K ^TMP("SCMC",$J) - S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" - S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 - S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP - S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation" - D LINES(3) - D ^XMD - D PRMAIL^SCMCTSK5(3) - S DISUPNO=1 - K ^TMP("SCMC",$J),^TMP("SCMCTXT") - S XMSUB="Patients Automated Inactivations from PC Panels" - S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - K ^TMP("SCMC",$J) - S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" - S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 - S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP - S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days" - D LINES(2) - D ^XMD - S DISUPNO=1 - D PRMAIL^SCMCTSK5(2) - K ^TMP("SCMC",$J),^TMP("SCMCTXT") - I $P($G(^SCTM(404.44,1,1)),U,11)="" D - . S XMSUB="PC Providers Scheduled for Inactivation" - . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" - . K ^TMP("SCMC",$J) - . S XMTEXT="^TMP(""SCMCTXT"",$J," - . S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 - . S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP - . D LINES(4) - . D ^XMD - . D PRMAIL^SCMCTSK5(4) - . D BULL^SCMCTSK6 - Q -LINES(TYPE) ;Lines of Bulletin - D LINES^SCMCTSK5(TYPE) Q -ROLE(DATA,INFO) ;SCMC ROLE - N ROLE,TP,I - S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2) - S DATA(0)="0^0^0" - I 'ROLE Q - I 'TP Q - S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3) ;I DATA(0)=3!(DATA(0)=0) S DATA(0)=DATA(0)_"^0^0" Q - I $$DATES^SCAPMCU1(404.53,+TP) S DATA(0)=DATA(0)_"^1^0" Q - N PREC S PREC=0 - F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I D Q:PREC - .I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1 - I PREC S DATA(0)=DATA(0)_"^0^1" Q - S DATA(0)=DATA(0)_"^0^0" - Q -INRPT ; REPORT - N DIOEND,SCDHD - D PROMPT^SCMCTSK3("** Date Range Selection **","DATE PATIENTS INACTIVATED FROM PC PANELS") - Q:'$D(^TMP("SC",$J,"XR")) - D UNASSIGN^SCMCTSK3 - S Q="""" - S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]" - D BY - S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT" - S DIOBEG="D DIOBEG^SCMCTSK4" - S DIOEND="D DIOEND1^SCMCTSK4" - S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") - D EN1^DIP - Q -IN30 ;inact. last month - N DIPA,SDD D SORT^SCMCTSK1(.DIPA,.SDD) Q:'SDD ;SD/499 - S Q="""" - S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]" - S DHD="Patients Inactivated from Primary Care Panels in the Past Month" - S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") - D EN1^DIP - Q -EXRPT ;EXTEND REPORT - K CLIN,TEAM,INST - D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date") - Q:'$D(^TMP("SC",$J,"XR")) - S Q="""",SORT=1 - D EXTEND^SCMCTSK3 - S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]" - S (SCDHD,DHD)="PCMM Patients with extended Inactivations" - S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9" - D BY - S FLDS="[SCMC EXTENDED]" - D EN1^DIP - Q -BY N DISPAR - S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01" - F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A) S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D - .I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@" - .I $G(SCDHD)["FTEE" D - ..I A["PROV" S $P(DISPAR(0,I),U)="@" - ..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U) - S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")="" - Q -FLRPT ;FLAGGED REPORT - D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation") - Q:'$D(^TMP("SC",$J,"XR")) - D FLAGG^SCMCTSK3 - S Q="""" - S DIC="^SCPT(404.43,",L=0 - S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels" - D BY - S DIOBEG="D DIOBEG^SCMCTSK4" - S FLDS="[SCMC PENDING UNASSIGN]" - I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]" - S DIOEND="D DIOEND^SCMCTSK4" - D EN1^DIP +SCMCTSK2 ;ALB/JDS - PCMM Inactivation Nightly Job; 18 Apr 2003 9:36 AM ; 10/24/07 12:23pm + ;;5.3;Scheduling;**297,498,527**;AUG 13, 1993;Build 6 + Q +NIGHT ;nightly task for inact. + N ENDDT,NOINAC,SIXM,FLGDT,L,PATDT,SEEN + K ^TMP("SCTSK",$J) + D DT^DICRW + S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA
ENDDT))) D + .F ENTRY=0:0 S ENTRY=$O(^SCPT(404.43,"AFLG",DATE,ENTRY)) Q:'ENTRY D + ..S ZERO=$G(^SCPT(404.43,ENTRY,0)) Q:'ZERO + ..S DFN=+$G(^SCPT(404.42,+ZERO,0)) Q:'DFN + ..S POS=$P(ZERO,U,2) + ..I $P(ZERO,U,4) D UNFLG Q ;already unassigned + ..I $P(ZERO,U,13) S X1=DATE,X2=$S(ALPHA:4,1:90) D C^%DTC S FLGDT=X I FLGDT>DT Q ;ext + ..;check if criteria still met + ..I $P(ZERO,U,17) D UNFLG Q ;Already reactivated + ..;get preceptor position + ..S %DT="",X="T-12M" D ^%DT S STDT=+Y + ..S PREC=$$DATES^SCAPMCU1(404.53,+POS),PREC=$S(PREC:$P($G(^SCTM(404.53,+$P(PREC,U,4),0)),U,6),1:+POS) + ..;see if provider changed + ..I $O(^SCTM(404.52,"AIDT",+PREC,1,-STDT),-1) D UNFLG Q + ..I '$P(ZERO,U,5) D UNFLG Q ;Not primary care + ..S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) + ..S PC=$$GET^XUA4A72(+PROV) + ..S SC297=$$PDAT^SCMCGU("SD*5.3*297") + ..N NEW S NEW=$S($P(ZERO,U,3)330:0,1:1) + ..S X1=DT,X2=SC297 D D^%DTC S SC297=X + ..S X="T-"_$S(SC297>365:"11M",NEW:"11M",1:"23M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D UNFLG Q + ..S X="T-"_$S(SC297>365:"12M",NEW:"12M",1:"24M") D ^%DT S TYDT=+Y D SEEN^SCMCTSK1 I $G(SEEN) D:(DATE>ENDDT) UNFLG Q + ..I ('NOINAC)&(DATE'>ENDDT) D DIS^SCMCTSK1 + ..;D MSG(POS,DFN) + ;if 6 months after installation check to flag providers + I NOINAC D:ALPHA BULL Q + S PATDT=$$PDAT^SCMCGU("SD*5.3*297") Q:'PATDT + I SIXM,SIXM'>DT D + .D PRINAC + .N FLDA + .S FLDA(404.44,"1,",19)="" + .D FILE^DIE("I","FLDA","ERR") + D BULL + Q +UNFLG ;Remove the flag + N DR,DIE,DA + S DR=".15///@;.13///@;.12///@",DIE="^SCPT(404.43,",DA=ENTRY D ^DIE + Q +PRFLAG ;flag incorrect provider positions + N POS + ;provider inactivation has run once + I $P($G(^SCTM(404.44,1,1)),U,11)'="" Q + D PRFLAG^SCMCTSK3 + Q +PRINAC ;inactivate flagged providers + N I,II + ;Provider inactivation run already + S II=$P($G(^SCTM(404.44,1,1)),U,11) I II'="",II'=DT Q + F I=0:0 S I=$O(^SCTM(404.52,I)) Q:'I S ZERO=$G(^(I,0)) I $P(ZERO,U,10) D + .;I $P(ZERO,U,10)>$G(ENDT) Q ;not time yet + .I $O(^SCTM(404.52,"AIDT",+ZERO,0,-9999999))<(-$P(ZERO,U,2)) Q ;already inactivated + .;Check if criteria still valid + .S POS=+ZERO + .S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) + .S PC=$$GET^XUA4A72(+PROV) + .S DR=".091///@",DIE="^SCTM(404.52,",DA=I D ^DIE ;remove flag + .S ZERO1=$G(^SCTM(404.57,POS,0)) + .I '$D(^SD(403.46,+$P(ZERO1,U,3),2,+PC)) D + ..;enter the inactivation + ..S DIC="^SCTM(404.52,",X=+ZERO,DIC("DR")=".02////"_DT_";.03////"_$P(ZERO,U,3)_";.04////0;.05///EMPLOYEE LEAVES POSITION;.11////1" + ..S DIC(0)="LM" D ^DIC + ;only run the inactivation once. + S $P(^SCTM(404.44,1,1),U,11)=DT + Q +FUTAPP(DFN) ;print future appointments + N TAB,SCDT0 S TAB=$X + S SCDT=DT+.24 + F S SCDT=$O(^DPT(DFN,"S",SCDT)) Q:'SCDT D + . S SCDT0=$G(^DPT(DFN,"S",SCDT,0)) Q:$L($P(SCDT0,U,2)) + . S CLIEN=$P(SCDT0,"^") Q:'CLIEN + . S Y=SCDT X ^DD("DD") W $E(Y_" ",1,17)_" "_$E($P($G(^SC(+CLIEN,0)),U),1,10) + Q +GETASC(DATA,ENTRY) ;get associated clinics + N I,CNT S CNT=0 + F I=0:0 S I=$O(^SCTM(404.57,+$G(ENTRY),5,I)) Q:'I S CNT=CNT+1,DATA(CNT)=I_U_$P($G(^SC(I,0)),U) + Q +SETASC(RESULT,DATA) ;set associated clinics + D SETASC^SCMCTSK7(.RESULT,DATA) Q +MSG(SCTP,DFN) ;send inactivation message + ;given list of valid positions get current practitioners + S SCLIST="SCL" + I "N"'[$P($G(^SCTM(404.57,SCTP,2)),U,9) D + .S SCOK=$$PRTP^SCAPMC(SCTP,"",.SCLIST,.SCERR) + .;if preceptor notice turned on for message type + I +$P($G(^SCTM(404.57,SCTP,2)),U,9) D + .S SCX=+$$OKPREC2^SCMCLK(SCTP,DT) + .;if preceptor duz returned, add to array + .I SCX S @SCLIST@("SCPR",SCX)="" + N XMY F I=0:0 S I=$O(@SCLIST@("SCPR",I)) Q:'I S XMY(I)="" + S SCTEXT(1,0)="PATIENT "_$P($G(^DPT(DFN,0)),U)_" has been inactivated from primary care team position "_$P($G(^SCTM(404.57,SCTP,0)),U) + S XMSUB="Provider's Inactivated Primary Care Patients" D ^XMD + Q +BULL ;end of Month Bulletin + N DISUPNO,BY,DHIT,HEAD + S DISUPNO=1,L=0 + S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel" + S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J),^TMP("SCML",$J) + S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" + S DIC="^SCPT(404.43,",BY="[SCMC FLAGGED BULLETIN]",FLDS="[SC BULLETIN]",CNT=0 + S:0 FLDS="" S IOP="",DHD="@@",(FR,TO)="" D EN1^DIP + S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients scheduled for inactivation in next 30 days" + D LINES(1) + D ^XMD + D PRMAIL^SCMCTSK5(1) + F SCI=0:0 S SCI=$O(^TMP("SCF",$J,SCI)) Q:'SCI D + .K XMY S XMY(SCI)="" K ^TMP("SCMC",$J),^TMP("SCMCTXT",$J) + .M ^TMP("SCMC",$J)=^TMP("SCF",$J,SCI) + .S XMSUB="Patients Scheduled for Inactivation from Primary Care Panel" + .S XMTEXT="^TMP(""SCMCTXT"",$J," + .;D LINES(1) D ^XMD + S DISUPNO=1 + K ^TMP("SCMC",$J),^TMP("SCMCTXT") + S XMSUB="Patients With Extended PCMM Inactivation Dates" + S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + K ^TMP("SCMC",$J) + S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" + S DIC="^SCPT(404.43,",BY="[SCMC EXTENDED BULLETIN]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 + S FR=",,,",TO=FR,FLDS="",IOP="",DHD="@@" D EN1^DIP + S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Extended from inactivation" + D LINES(3) + D ^XMD + D PRMAIL^SCMCTSK5(3) + S DISUPNO=1 + K ^TMP("SCMC",$J),^TMP("SCMCTXT") + S XMSUB="Patients Automated Inactivations from Primary Care Panels" + S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + K ^TMP("SCMC",$J) + S XMTEXT="^TMP(""SCMCTXT"",$J," ;S @XMTEXT@(0)="" + S DIC="^SCPT(404.43,",BY="[SCMC INACTIVATED]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 + S FLDS="",IOP="",DHD="@@",FR=",T-30,,",TO=",,,,," D EN1^DIP + S ^TMP("SCMCTXT",$J,1,0)="There are "_$O(^TMP("SCMC",$J,""),-1)_" Patients Inactivated in last 30 days" + D LINES(2) + D ^XMD + S DISUPNO=1 + D PRMAIL^SCMCTSK5(2) + K ^TMP("SCMC",$J),^TMP("SCMCTXT") + I $P($G(^SCTM(404.44,1,1)),U,11)="" D + . S XMSUB="Primary Care Providers Scheduled for Inactivation" + . S XMY("G.PCMM PATIENT/PROVIDER INACTIVE")="" + . K ^TMP("SCMC",$J) + . S XMTEXT="^TMP(""SCMCTXT"",$J," + . S DIC="^SCTM(404.52,",BY="[SC PROVIDER FLAGGED BULLE]",DHIT="S CNT=$G(CNT)+1,^TMP(""SCMC"",$J,CNT,D0)=""""",CNT=0 + . S FLDS="",IOP="",DHD="@@",FR="",TO="" D EN1^DIP + . D LINES(4) + . D ^XMD + . D PRMAIL^SCMCTSK5(4) + . D BULL^SCMCTSK6 + Q +LINES(TYPE) ;Lines of Bulletin + D LINES^SCMCTSK5(TYPE) Q +ROLE(DATA,INFO) ;SCMC ROLE + N ROLE,TP,I + S ROLE=+$G(INFO),TP=+$P($G(INFO),U,2) + S DATA(0)="0^0^0" + I 'ROLE Q + I 'TP Q + S DATA(0)=+$P($G(^SD(403.46,ROLE,0)),U,3) ;I DATA(0)=3!(DATA(0)=0) S DATA(0)=DATA(0)_"^0^0" Q + I $$DATES^SCAPMCU1(404.53,+TP) S DATA(0)=DATA(0)_"^1^0" Q + N PREC S PREC=0 + F I=0:0 S I=$O(^SCTM(404.53,"AD",TP,I)) Q:'I D Q:PREC + .I $D(^SCTM(404.53,"AD",TP,I,1)) I '$D(^(0)) S PREC=1 + I PREC S DATA(0)=DATA(0)_"^0^1" Q + S DATA(0)=DATA(0)_"^0^0" + Q +INRPT ; REPORT + N DIOEND,SCDHD + D PROMPT^SCMCTSK3("**** Date Range Selection ****","DATE PATIENTS INACTIVATED FROM PRIMARY CARE PANELS") + Q:'$D(^TMP("SC",$J,"XR")) + D UNASSIGN^SCMCTSK3 + S Q="""" + S DIC="^SCPT(404.43," ;=0,BY="[SCMC INACTIVATION SORT]" + D BY + S (SCDHD,DHD)="AUTOMATED PATIENT INACTIVATION FROM PRIMARY CARE PANELS REPORT" + S DIOBEG="D DIOBEG^SCMCTSK4" + S DIOEND="D DIOEND1^SCMCTSK4" + S FLDS="[SCMC INACTIVATED]" ;,FR="?,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") + D EN1^DIP + Q +IN30 ;inactivated last month + D SORT^SCMCTSK1 Q:'X + S Q="""" + S DIC="^SCPT(404.43,",L=0,BY="[SCMC INACTIVATION SORT]" + S DHD="Patients Inactivated from Primary Care Panels in the Past Month" + S FLDS="[SCMC INACTIVATED]",FR="T-31,,"_$TR(DIPA("SI"),","," "),TO="T,,"_$TR(DIPA("EI")_"z",","," ") + D EN1^DIP + Q +EXRPT ;EXTEND REPORT + K CLIN,TEAM,INST + D PROMPT^SCMCTSK3("PCMM Patients with Extended Inactivations","Scheduled Inactivation Date") + Q:'$D(^TMP("SC",$J,"XR")) + S Q="""",SORT=1 + D EXTEND^SCMCTSK3 + S DIC="^SCPT(404.43," ;,L=0,BY="[SCMC EXTENDED]" + S (SCDHD,DHD)="PCMM Patients with extended Inactivations" + S DIOBEG="D DIOBEG^SCMCTSK4",DIOEND="D EXTKEY^SCMCTSK9" + D BY + S FLDS="[SCMC EXTENDED]" + D EN1^DIP + Q +BY N DISPAR + S BY(0)="^TMP(""SCSORT"",$J)",L(0)=$O(^TMP("SC",$J,"SORT",99),-1)+1,DISPAR(0,1)="+",L=0 I $G(SCDHD)["FTEE" S DISPAR(0,1)="+#" ;BY="@'.01" + F I=1:1:$L(SORTN,U) S A=$P(SORTN,U,I) Q:'$L(A) S $P(DISPAR(0,I),U,2)=";"_Q_A_": "_Q D + .I A["PATIENT" I (I>1)!($G(SCDHD)["Patients Scheduled for Inactivation from PC Panel") S $P(DISPAR(0,I),U)="@" + .I $G(SCDHD)["FTEE" D + ..I A["PROV" S $P(DISPAR(0,I),U)="@" + ..I I>1 I (A["CLI")!(A["POS") S $P(DISPAR(0,I),U)="@"_$P($G(DISPAR(0,I)),U) + S ZTSAVE("^TMP(""SC"",$J,")="",ZTSAVE("^TMP(""SCSORT"",$J,")="" + Q +FLRPT ;FLAGGED REPORT + D PROMPT^SCMCTSK3("Patients Scheduled for Inactivation from PC Panels","Date Scheduled for Inactivation") + Q:'$D(^TMP("SC",$J,"XR")) + D FLAGG^SCMCTSK3 + S Q="""" + S DIC="^SCPT(404.43,",L=0 + S (SCDHD,DHD)="Patients Scheduled for Inactivation from PC Panels" + D BY + S DIOBEG="D DIOBEG^SCMCTSK4" + S FLDS="[SCMC PENDING UNASSIGN]" + I $G(DISPAR(0,1))["PATIENT" S FLDS="[SCMC PENDING UNASSIGN PAT]" + S DIOEND="D DIOEND^SCMCTSK4" + D EN1^DIP Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK3.m (revision 623) @@ -1,223 +1,218 @@ -SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am ; Compiled June 7, 2007 13:57:55 ; Compiled February 12, 2008 11:46:47 - ;;5.3;Scheduling;**297,499**;AUG 13, 1993;Build 21 - Q -SORTP ;sort template - N DIC - S DIC=200,DIC(0)="ZME" - S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))" - S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR - I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q - D ^DIC I Y<0 S DIPA("SP")=X Q:X[U D - .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR - .I X="LAST" S DIPA("EP")="zzz" - I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: " - D ^DIC - I Y>0 S DIPA("EP")=$P(Y(0),U) - I Y<0 S DIPA("EP")=X Q:X[U - S X=1 Q - Q -KEY ;Inactivated Report Key - D KEY^SCMCTSK3 Q -SORTYP() ; sort type - W !,"Sort report by" - S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;" - S DIR("B")=1 - D ^DIR - Q Y -DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position - N A,B,C,T,I,INSTNM,INSTN - S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2) - S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1 - S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99) - S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2) -EC(PP) ;return enrolled clinics - N I,A - S A="" - F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I D - .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled - .I $D(CLIN(I)) S A=A_CLIN(I)_U Q - .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q - .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U - Q $S(A="":-1,1:A) -TM(PP) ;Return Team - N I,A,T - S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3) - I $D(TEAM(T)) Q TEAM(T) - I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1 - S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U) - I '$L(TEAM(T)) K TEAM(T) Q -1 - Q TEAM(T) -IU(DFN) ;is patient inactivity unassigned - N I,A,B,DATA,QUIT - S DATA=-1,QUIT=0 - F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I S A=$G(^SCPT(404.42,I,0)) D Q:QUIT - .F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J S B=$G(^SCPT(404.43,+J,0)) D Q:QUIT - ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q - ..I $P(B,U,12)="NA" S POS=+J D - ...S A("IU",I)=A - ...S A("IUA")=A - ...S A("IUB")=B - ...I $P(A,U,8),'$P(A,U,9) S A("A")=1 - ;Q:$D(A("A")) DATA - Q:'$D(A("IU")) DATA - ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS - S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS - Q DATA -PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report - ;Input: LIST=comma delimited string of list subscripts to prompt for - ;Input: SCRTN=report routine entry point - ;Input: SCDESC=tasked job description - ; - K TEAM,CLIN,INST,^TMP("SCSORT",$J) - N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT - D HOME^%ZIS - D ENS^%ZISS - S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0 - D TITL^SCRPW50(SCDESC) - I $L($G(DATESORT)) D G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END - .D SUBT^SCRPW50(DATESORT) - .S SCBDT("B")="T-30",SCEDT("B")="TODAY" - .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+60" - S LIST="DIV,TEAM,POS,ASPR" - ;D SUBT^SCRPW50("**** Date Range Selection ****") - ;S (SCBDT("B"),SCEDT("B"))="TODAY" - ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END - ;D SUBT^SCRPW50("**** Report Parameter Selection ****") - F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT - .S SCOUT='$$LIST^SCRPO(.SC,SCX,1) - .Q - G:SCOUT END - S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT") - D SUBT^SCRPW50("**** Output sort order (optional) ****") - G:'$$SORT^SCRPO(.SC,SORT,"") END - S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1)) - G:'$$PPAR^SCRPO(.SC,1,.SCT) END - S SORTN="" - F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI S SORTN=SORTN_$P(^(SCI),U,2)_U - W:$G(IORESET)'[$C(99) $G(IORESET) - Q -END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q -EXTEND ;Sort Extend - K ^TMP("SCSORT",$J) - I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION" - N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" - N I,A,ED,SD - F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J D - .I '$P($G(^SCPT(404.43,J,0)),U,15) Q - .S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (XED) Q - .D SORT(0) - Q -FILEIN(DATA,INFO) ;undo a inactivation - ;INFO entry in PATIENT POSITION ASSIGNMENT file - N ZERO,FLDA S DATA=1 - S ZERO=$G(^SCPT(404.43,+$G(INFO),0)) - ;I $P(ZERO,U,12)'="IU" Q - S FLDA(404.43,(+INFO)_",",.12)="" - S FLDA(404.43,(+INFO)_",",.04)="" - S FLDA(404.43,(+INFO)_",",.15)="" - S FLDA(404.43,(+INFO)_",",.17)=DT - I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)="" - D FILE^DIE("E","FLDA","ERR") - Q -UNASSIGN ;Sort UNASSIGNMENTS - N END,START - K ^TMP("SCSORT",$J) - S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9 - I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION" - N I,A,STAT - F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J D - .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)END) Q - .D SORT(1) - Q -DFN(A) ;Return patient from Position assigment - Q +$G(^SCPT(404.42,+$G(A),0)) -PA(A) ;return patient name - Q $P($G(^DPT(+$G(DFN),0)),U) -PR(PP) ;Return assigned provider - N A - S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT) - I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1 - S A=$P(A,U,2) - Q $S(A="":-1,1:A) -TP(A) ;return the team position - N TP S TP=+$P($G(ZERO),U,2) - I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1 - Q $P($G(^SCTM(404.57,+TP,0)),U) -FLAGG ;Sort FLAGGED - K ^TMP("SCSORT",$J) - N I,A,J - I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT" - N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" - S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9 - F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J D - .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (XEND) Q - .D SORT(0) - Q -SORT(INACTIVE) ; - N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE - S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4)) - S DFN=$$DFN(+ZERO) - S QUIT=0,KCNT=0 - F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K)) S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q - .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K - Q:QUIT - S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q - Q:QUIT - F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D - .S B="E" K @B - .F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C - .S @B@(J)="" - .M ^TMP("SCSORT",$J)=E - Q -INACT ; - N ALPHA,ZERO - S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA
$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)="" - I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR") - K ^TMP("SCMCTSK",$J) - Q +SCMCTSK3 ;ALB/JDS - PCMM Inactivation Reports ; 7/19/05 10:06am + ;;5.3;Scheduling;**297**;AUG 13, 1993 + Q +SORTP ;sort template + N DIC + S DIC=200,DIC(0)="ZME" + S DIC("S")="I $D(^SCTM(404.52,""C"",+Y))" + S DIR("A")="Start with Provider",DIR("B")="FIRST",DIR(0)="F" D ^DIR + I X="FIRST" S DIPA("SP")="",DIPA("EI")="zzz",X=1 Q + D ^DIC I Y<0 S DIPA("SP")=X Q:X[U D + .S DIR("A")="Go to Provider",DIR("B")="LAST" S DIR(0)="F" D ^DIR + .I X="LAST" S DIPA("EP")="zzz" + I Y>0 S DIPA("SP")=$P(Y(0),U),DIC(0)="AZQME",DIC("A")="Go to Provider: " + D ^DIC + I Y>0 S DIPA("EP")=$P(Y(0),U) + I Y<0 S DIPA("EP")=X Q:X[U + S X=1 Q + Q +KEY ;Inactivated Report Key + D KEY^SCMCTSK3 Q +SORTYP() ; sort type + W !,"Sort report by" + S DIR(0)="SO^1:TEAM;2:ASSOCIATED CLINIC;" + S DIR("B")=1 + D ^DIR + Q Y +DV(PP) ;return institution sort of patient assignment entry and then IEN of team^ien of position + N A,B,C,T,I,INSTNM,INSTN + S A=$G(^SCPT(404.43,+PP,0)),T=+$P($G(^SCPT(404.42,+A,0)),U,3) I $D(INST(T)) Q INST(T)_U_T_U_$P(A,U,2) + S I=$P($G(^SCTM(404.51,T,0)),U,7) I $O(^TMP("SC",$J,"DIV",0)) I '$D(^TMP("SC",$J,"DIV",I)) Q -1 + S INSTNM=$$GET1^DIQ(4,(+I)_",",.01),INSTN=$$GET1^DIQ(4,(+I)_",",99) + S INST(T)=$S($L(INSTN)=3:INSTN_" ",1:"")_INSTNM Q INST(T)_U_T_U_$P(A,U,2) +EC(PP) ;return enrolled clinics + N I,A + S A="" + F I=0:0 S I=$O(^SCTM(404.57,+$P(ZERO,U,2),5,I)) Q:'I D + .I '$$PTCL^SCRPO2(DFN,U_I,0,DT) Q ;not enrolled + .I $D(CLIN(I)) S A=A_CLIN(I)_U Q + .I $O(^TMP("SC",$J,"CLINIC",0)) I '$D(^(I)) Q + .S CLIN(I)=$P($G(^SC(I,0)),U) I $L(CLIN(I)) S A=A_CLIN(I)_U + Q $S(A="":-1,1:A) +TM(PP) ;Return Team + N I,A,T + S T=+$P($G(^SCPT(404.42,+ZERO,0)),U,3) + I $D(TEAM(T)) Q TEAM(T) + I $O(^TMP("SC",$J,"TEAM",0)) I '$D(^(T)) Q -1 + S TEAM(T)=$P($G(^SCTM(404.51,+T,0)),U) + I '$L(TEAM(T)) K TEAM(T) Q -1 + Q TEAM(T) +IU(DFN) ;is patient inactivity unassigned + N I,A,B,DATA,QUIT + S DATA=-1,QUIT=0 + F I=0:0 S I=$O(^SCPT(404.42,"B",+$G(DFN),I)) Q:'I S A=$G(^SCPT(404.42,I,0)) D Q:QUIT + .F J=0:0 S J=$O(^SCPT(404.43,"B",I,J)) Q:'J S B=$G(^SCPT(404.43,+J,0)) D Q:QUIT + ..I $P(B,U,5),'$P(B,U,4) K A S QUIT=1 Q + ..I $P(B,U,12)="NA" S POS=+J D + ...S A("IU",I)=A + ...S A("IUA")=A + ...S A("IUB")=B + ...I $P(A,U,8),'$P(A,U,9) S A("A")=1 + ;Q:$D(A("A")) DATA + Q:'$D(A("IU")) DATA + ;S DATA="1~"_$P(^SCTM(404.51,+$P(A,U,3),0),U)_"~"_(+$P(A,U,3))_"~"_$P($G(^SCTM(404.57,+$P(B,U,2),0)),U)_"~"_($P(B,U,2))_"~"_POS + S DATA="1~"_$P(^SCTM(404.51,+$P(A("IUA"),U,3),0),U)_"~"_(+$P(A("IUA"),U,3))_"~"_$P($G(^SCTM(404.57,+$P(A("IUB"),U,2),0)),U)_"~"_($P(A("IUB"),U,2))_"~"_POS + Q DATA +PROMPT(SCDESC,DATESORT) ;Prompt for report parameters, queue report + ;Input: LIST=comma delimited string of list subscripts to prompt for + ;Input: SCRTN=report routine entry point + ;Input: SCDESC=tasked job description + ; + K TEAM,CLIN,INST,^TMP("SCSORT",$J) + N SCDIV,SCBDT,SCEDT,SC,SCI,SCX,SCOUT,SCT + D HOME^%ZIS + D ENS^%ZISS + S SC="^TMP(""SC"",$J)" K @SC S SCOUT=0 + D TITL^SCRPW50(SCDESC) + I $L($G(DATESORT)) D G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END + .D SUBT^SCRPW50(DATESORT) + .S SCBDT("B")="T-30",SCEDT("B")="TODAY" + .I (DATESORT["Scheduled Ina")!(DATESORT["Scheduled for Inactivation") S SCEDT("B")="T+30" + S LIST="DIV,TEAM,POS,ASPR" + ;D SUBT^SCRPW50("**** Date Range Selection ****") + ;S (SCBDT("B"),SCEDT("B"))="TODAY" + ;G:'$$DTR^SCRPO(.SC,.SCBDT,.SCEDT) END + ;D SUBT^SCRPW50("**** Report Parameter Selection ****") + F SCI=1:1:$L(LIST,",") S SCX=$P(LIST,",",SCI) D Q:SCOUT + .S SCOUT='$$LIST^SCRPO(.SC,SCX,1) + .Q + G:SCOUT END + S SORT="DV,TM,TP,PR"_$S(SCDESC["FTEE":",AC",1:",PT") + D SUBT^SCRPW50("**** Output sort order (optional) ****") + G:'$$SORT^SCRPO(.SC,SORT,"") END + S SCT(1)="**** Report Parameters Selected ****" D SUBT^SCRPW50(SCT(1)) + G:'$$PPAR^SCRPO(.SC,1,.SCT) END + S SORTN="" + F SCI=0:0 S SCI=$O(^TMP("SC",$J,"SORT",SCI)) Q:'SCI S SORTN=SORTN_$P(^(SCI),U,2)_U + W:$G(IORESET)'[$C(99) $G(IORESET) + Q +END W:$G(IORESET)'[$C(99) $G(IORESET) K ^TMP("SC",$J) Q +EXTEND ;Sort Extend + K ^TMP("SCSORT",$J) + I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="DIVISION" + N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" + N I,A,ED,SD + F I=0:0 S I=$O(^SCPT(404.43,"AEXT",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AEXT",I,J)) Q:'J D + .I '$P($G(^SCPT(404.43,J,0)),U,15) Q + .S SD=$G(^TMP("SC",$J,"DTR","BEGIN")) I SD S ED=$G(^("END")) S:'ED ED=9999999 D INACTDT^SCMCTSK1(J) I (XED) Q + .D SORT(0) + Q +FILEIN(DATA,INFO) ;undo a inactivation + ;INFO entry in PATIENT POSITION ASSIGNMENT file + N ZERO,FLDA S DATA=1 + S ZERO=$G(^SCPT(404.43,+$G(INFO),0)) + ;I $P(ZERO,U,12)'="IU" Q + S FLDA(404.43,(+INFO)_",",.12)="" + S FLDA(404.43,(+INFO)_",",.04)="" + S FLDA(404.43,(+INFO)_",",.15)="" + S FLDA(404.43,(+INFO)_",",.17)=DT + I $D(^SCPT(404.42,+ZERO,0)) S FLDA(404.42,(+ZERO)_",",.15)="",FLDA(404.42,(+ZERO)_",",.09)="" + D FILE^DIE("E","FLDA","ERR") + Q +UNASSIGN ;Sort UNASSIGNMENTS + N END,START + K ^TMP("SCSORT",$J) + S START=$G(^TMP("SC",$J,"DTR","BEGIN"))-.1,END=$G(^("END"))+.9 + I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION" + N I,A,STAT + F STAT="NA","DU" F J=0:0 S J=$O(^SCPT(404.43,"ASTATB",STAT,J)) Q:'J D + .S ZERO=$G(^SCPT(404.43,J,0)) I ($P(ZERO,U,4)END) Q + .D SORT(1) + Q +DFN(A) ;Return patient from Position assigment + Q +$G(^SCPT(404.42,+$G(A),0)) +PA(A) ;return patient name + Q $P($G(^DPT(+$G(DFN),0)),U) +PR(PP) ;Return assigned provider + N A + S A=$$GETPRTP^SCAPMCU2(+$P(ZERO,U,2),DT) + I $O(^TMP("SC",$J,"ASPR",0)) I '$D(^(+A)) Q -1 + S A=$P(A,U,2) + Q $S(A="":-1,1:A) +TP(A) ;return the team position + N TP S TP=+$P($G(ZERO),U,2) + I $O(^TMP("SC",$J,"POS",0)) I '$D(^(TP)) Q -1 + Q $P($G(^SCTM(404.57,+TP,0)),U) +FLAGG ;Sort FLAGGED + K ^TMP("SCSORT",$J) + N I,A,J + I '$D(^TMP("SC",$J,"SORT",1)) S ^(1)="DV^INSTITUTION^SCDIV",SORTN="INSTITUTION",^(2)="TM^TEAM^SCTEAM",^(3)="PR^PROVIDER^SCPROV",^(4)="PA^PATIENT^SCPAT" + N SORT S A="" F S A=$O(^TMP("SC",$J,A)) Q:A="" I "XRSORTDTR"'[A I $G(^(A))'="ALL" S SORT($S(A="ASPR":"PR",A="DIV":"DV",A="POS":"TP",1:"TM",A="PATIENT":PT))="" + S SDT=$G(^TMP("SC",$J,"DTR","BEGIN")),END=$G(^("END"))+.9 + F I=0:0 S I=$O(^SCPT(404.43,"AFLG",I)) Q:'I F J=0:0 S J=$O(^SCPT(404.43,"AFLG",I,J)) Q:'J D + .I SDT>0 S:(END'>9) END=9999999 D INACTDT^SCMCTSK1(J) I (XEND) Q + .D SORT(0) + Q +SORT(INACTIVE) ; + N A,B,C,D,E,QUIT,SCA,K,KCNT,PIECE + S ZERO=$G(^SCPT(404.43,+J,0)) Q:$S('$G(INACTIVE):$P(ZERO,U,4),1:'$P(ZERO,U,4)) + S DFN=$$DFN(+ZERO) + S QUIT=0,KCNT=0 + F K=1:1 Q:'$D(^TMP("SC",$J,"SORT",K)) S A=^(K) K SORT($P(A,U)) S @("A("_K_")=$$"_$P(A,U)_"("_J_")") D I (A(K)=-1)!($P(A(K),U)="") S QUIT=1 Q + .I $P(A,U)="EC",$L(A(K),U)>2 S KCNT=K + Q:QUIT + S A="" F S A=$O(SORT(A)) Q:A="" S @("B=$$"_A_"("_J_")") I B=-1 S QUIT=1 Q + Q:QUIT + F PIECE=1:1:$S(KCNT:$L(A(KCNT),U)-1,1:1) D + .S B="E" K @B + .F K=1:1:$O(A(99),-1) S @B@($P(A(K),U,$S(K=KCNT:PIECE,1:1)))="" S C=$Q(@B) K @B S B=C + .S @B@(J)="" + .M ^TMP("SCSORT",$J)=E + Q +INACT ; + N ALPHA,ZERO + S ALPHA=$G(^SCTM(404.44,1,1)),ALPHA=$P(ALPHA,U,8) I ALPHA
$P(ZERO,U,2) S FLDA(404.52,POSH_",",.091)="" + I $O(FLDA(0)) D FILE^DIE("I","FLDA","ERR") + K ^TMP("SCMCTSK",$J) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK4.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK4.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK4.m (revision 623) @@ -1,80 +1,80 @@ -SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003 9:36 AM - ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8 - Q -POSCHK ; - N NAME S NAME=$P($G(^SD(403.46,+$P(INFO,U,3),0)),U) - I "RESIDENT (PHYSICIAN)INTERN (PHYSICIAN)"[NAME S $P(DATA,U,3)=1 Q - I "NURSE PRACTITIONERPHYSICIAN ASSISTANT"[NAME S $P(DATA,U,3)=2 Q - I "PHYSICIAN-ATTENDINGPHYSICIAN-PRIMARY CARENURSE PRACTITIONERPHYSICIAN ASSISTANTPHYSICIAN-PSYCHIATRIST"[NAME D Q - .S $P(DATA,U,3)=3 - Q -DIOBEG ; - N PG,DC - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: 1" - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W ?(IOM/2-24),"**** Report Parameters Selected ****",! - S SC="^TMP(""SC"",$J)" - S X=$$PPAR^SCMCTSK8(.SC,.SCT) - S (PG,DC)=1 - F Q:$Y>(IOSL-3) W ! - ;I IOST["C" W !! R SCX:DT I SCX[U S DIOUT=1 - Q -DIOEND ;print key - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: "_($G(DC)+1) - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W !," REPORT KEY" - W !," Field Name Explanation of field name" - W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider" - W !," SSN Patient SSN." - W !," PC Team Patient's assigned Primary Care team in PCMM." - W !," Provider Name of primary care practitioner/provider currently assigned to the patient. This will be an" - W !," Associate PC Provider if the patient is assigned to an AP, or it will be a Primary Care Provider" - W !," (PCP) if the patient is not assigned to an Associate PC Provider (AP.)" - W !," Team Position The name of the team position to which the current practitioner/provider is assigned." - W !," Institution/Division Institution name, previously called Division, in which patient receives primary care." - W !," Sched Date for Inactiva Date patient will be inactivated from PCMM and their Primary Care team and provider/position" - W !," panels. If the patient has a completed outpatient encounter with their current PCP or an" - W !," assigned AP before this date, the patient will not be inactivated. If the patient's" - W !," inactivation date is extended for 60 days, with the PCMM Extend Patient's Inactivation Date" - W !," option, the patient's inactivation will not occur until the new extended date for inactivation." - W !," Note: There is a patient reassignment option, which allows an inactivated patient to be" - W !," reactivated to their previous Primary Care team and position if they return for care." - W !," Next Appt Date Patient is scheduled for an appointment on this date." - W !," May indicate patient wants to continue their assignment to their Primary Care team and provider." - W !," Clinic for next Appt The clinic in which the patient has their next scheduled appointment." - Q -DIOEND1 ;print Key - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: "_($G(DC)+1) - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W !," REPORT KEY" - W !," Field Name Explanation of field name" - W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." - W !," SSN Patient SSN." - W !," Institution Institution name, previously called Division, in which patient receives primary care." - W !," PC Team Patient's assigned Primary Care team in PCMM." - W !," Provider/ Name of Primary Care practitioner/provider currently assigned to the patient." - W !," This may be an Associate PC Provider (AP,) if the patient is assigned to an AP, or" - W !," it may be a Primary Care Provider (PCP) if the patient is not assigned to an" - W !," Associate PC Provider (AP.)" - W !," Team Position The name of the team position to which the current provider is assigned." - W !," Preceptor Name of Preceptor/Primary Care Provider (PCP) if the patient is assigned to an Associate Provider." - W !," If this field is blank then the patient is assigned to a PCP, who displays in the Provider field." - W !," Date Patient Date patient was inactivated from PCMM and their Primary Care team and provider/position." - W !," Inactivated Note: There is a PCMM patient re-assignment option." - W !," Reason Patient Reason for patient's automated unassignment from their Primary Care team and provider/position." - W !," Inactivated No Appt The patient has been assigned to their current Primary Care Provider (PCP) for" - W !," 12 months, and does not have a completed appointment encounter with their PCP or any assigned" - W !," Associated Primary Care Provider (AP) within those 12 months. Therefore, they are considered" - W !," an inactive patient. Alternatively, the patient has been assigned to their current PCP for at" - W !," least 12 months, and does not have a completed appointment encounter with their PCP or any" - W !," assigned Associated Primary Care Provider (AP) in the past 24 months. Therefore, they are" - W !," considered an inactive patient." - W !," Death - Patient's death, a date of death was entered in the Registration Package" - Q -DIOEND2 ;print Key +SCMCTSK4 ;ALB/JDS - PCMM Inactivation Reports ; 18 Apr 2003 9:36 AM + ;;5.3;Scheduling;**297**;AUG 13, 1993 + Q +POSCHK ; + N NAME S NAME=$P($G(^SD(403.46,+$P(INFO,U,3),0)),U) + I "RESIDENT (PHYSICIAN)INTERN (PHYSICIAN)"[NAME S $P(DATA,U,3)=1 Q + I "NURSE PRACTITIONERPHYSICIAN ASSISTANT"[NAME S $P(DATA,U,3)=2 Q + I "PHYSICIAN-ATTENDINGPHYSICIAN-PRIMARY CARENURSE PRACTITIONERPHYSICIAN ASSISTANTPHYSICIAN-PSYCHIATRIST"[NAME D Q + .S $P(DATA,U,3)=3 + Q +DIOBEG ; + N PG,DC + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: 1" + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W ?(IOM/2-24),"**** Report Parameters Selected ****",! + S SC="^TMP(""SC"",$J)" + S X=$$PPAR^SCMCTSK8(.SC,.SCT) + S (PG,DC)=1 + F Q:$Y>(IOSL-3) W ! + ;I IOST["C" W !! R SCX:DT I SCX[U S DIOUT=1 + Q +DIOEND ;print key + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: "_($G(DC)+1) + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W !," REPORT KEY" + W !," Field Name Explanation of field name" + W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider" + W !," SSN Patient's last 4 Social Security numbers." + W !," PC Team Patient's assigned Primary Care team in PCMM." + W !," Provider Name of primary care practitioner/provider currently assigned to the patient. This will be an" + W !," Associate PC Provider if the patient is assigned to an AP, or it will be a Primary Care Provider" + W !," (PCP) if the patient is not assigned to an Associate PC Provider (AP.)" + W !," Team Position The name of the team position to which the current practitioner/provider is assigned." + W !," Institution/Division Institution name, previously called Division, in which patient receives primary care." + W !," Sched Date for Inactiva Date patient will be inactivated from PCMM and their Primary Care team and provider/position" + W !," panels. If the patient has a completed outpatient encounter with their current PCP or an" + W !," assigned AP before this date, the patient will not be inactivated. If the patient's" + W !," inactivation date is extended for 60 days, with the PCMM Extend Patient's Inactivation Date" + W !," option, the patient's inactivation will not occur until the new extended date for inactivation." + W !," Note: There is a patient reassignment option, which allows an inactivated patient to be" + W !," reactivated to their previous Primary Care team and position if they return for care." + W !," Next Appt Date Patient is scheduled for an appointment on this date." + W !," May indicate patient wants to continue their assignment to their Primary Care team and provider." + W !," Clinic for next Appt The clinic in which the patient has their next scheduled appointment." + Q +DIOEND1 ;print Key + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: "_($G(DC)+1) + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W !," REPORT KEY" + W !," Field Name Explanation of field name" + W !," Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." + W !," SSN Patient's last 4 SSN numbers." + W !," Institution Institution name, previously called Division, in which patient receives primary care." + W !," PC Team Patient's assigned Primary Care team in PCMM." + W !," Provider/ Name of Primary Care practitioner/provider currently assigned to the patient." + W !," This may be an Associate PC Provider (AP,) if the patient is assigned to an AP, or" + W !," it may be a Primary Care Provider (PCP) if the patient is not assigned to an" + W !," Associate PC Provider (AP.)" + W !," Team Position The name of the team position to which the current provider is assigned." + W !," Preceptor Name of Preceptor/Primary Care Provider (PCP) if the patient is assigned to an Associate Provider." + W !," If this field is blank then the patient is assigned to a PCP, who displays in the Provider field." + W !," Date Patient Date patient was inactivated from PCMM and their Primary Care team and provider/position." + W !," Inactivated Note: There is a PCMM patient re-assignment option." + W !," Reason Patient Reason for patient's automated unassignment from their Primary Care team and provider/position." + W !," Inactivated No Appt The patient has been assigned to their current Primary Care Provider (PCP) for" + W !," 12 months, and does not have a completed appointment encounter with their PCP or any assigned" + W !," Associated Primary Care Provider (AP) within those 12 months. Therefore, they are considered" + W !," an inactive patient. Alternatively, the patient has been assigned to their current PCP for at" + W !," least 12 months, and does not have a completed appointment encounter with their PCP or any" + W !," assigned Associated Primary Care Provider (AP) in the past 24 months. Therefore, they are" + W !," considered an inactive patient." + W !," Death - Patient's death, a date of death was entered in the Registration Package" + Q +DIOEND2 ;print Key Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK9.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK9.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMCTSK9.m (revision 623) @@ -1,100 +1,100 @@ -SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM - ;;5.3;Scheduling;**297,526**;AUG 13, 1993;Build 8 - Q -EXTKEY ; - N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) - W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) - W ?(IOM-15),"PAGE: "_($G(DC)+1) - S Y="",$P(Y,"-",IOM)="" W !,Y,!! - W !,"Column Heading Explanation of column headings" - W ! - W !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." - W !,"SSN SSN number." - W !,"Institution Institution name, previously called Division, in which patient receives primary care." - W !,"PC Team The patient's assigned Primary Care team in PCMM." - W !,"Provider/ Name of Associate Primary Care Provider (AP) assigned to patient, if there is one." - W !," Team Position The name of the team position to which the Associate Primary Care Provider (AP) is assigned." - W !,"Current Preceptor/ Name of Primary Care Provider (PCP) assigned to patient. Every Primary Care patient should" - W !," Team Position be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)" - W !," is assigned." - W !,"Date Scheduled for Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless" - W !," Inactivation they have a completed outpatient appointment encounter with their current PCP or AP before this date." - W !," Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated" - W !," to their previous Primary Care team and position if they return for care." - W !,"Reason for Extended The reason entered for extending the patient's time before inactivation from PC panels." - W !," Inactivation Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for" - W !," Inactivation from PC Panels option." - Q -EXTCHUI ;roll n scroll option to extend a patient - N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1 - S SCTM=0 F D P1 Q:+SCTM<1 - Q -P1 D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1 - W !,"Searching...",! - D EXTEND(.SCARRAY,SCTM) - I $G(^TMP("SCMCTSK9","OUT",$J,1))="" W !,"No Patients to Extend..." D GCL Q - S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1) - S SCX=999 F Q:(SCX="^")!(SCX="") D P2 - Q -P2 W !,"Select From: ",!! - S V1=0 F S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1 D - . W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),! - F W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0)) D - . I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q - . I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q - I SCX'?1.9N Q - S DIE="^SCPT(404.43," - S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U) - S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ - D ^DIE - Q -EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days - ;IEN^POSITION^PATIENT^EXTENDED^REASON - K DATA,SCDATA,SDDATA - N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="" - D DT^DICRW S X="T-9M" D ^%DT S STDT=Y - S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 - S POSA="" - F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D - .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS -EX1 S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J) D - .S B=@A - .S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) - .S CNT=CNT+1 - Q -POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position - I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC - ;get patients for this position - K ^TMP("SC TMP LIST",$J) - S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) - S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D - .N J I $P(SCDATA,U,4)>STDT Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q - .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q - .S DFN=+SCDATA - .D SEEN Q:SEEN - .S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 - K @SCLIST - Q -SEEN ;was patient seen - S SEEN=0 - N SCPRO,I,PRECP,PRO - N X,SCPRDTS,SCPR - ;get list of providers for this position - S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)="" - S SCPRDTS("BEGIN")=TYDT - S SCPRDTS("END")=DT - S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR") - F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="" - S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)="" - F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN - .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN - ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q - ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN - ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ - ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q - Q -GCL ;clean temp globals - K ^TMP("SCMCTSK9",$J) - K ^TMP("SCMCTSK9","OUT",$J) - Q +SCMCTSK9 ;;BP/DMR - PCMM ; 18 Apr 2003 9:36 AM + ;;5.3;Scheduling;**297**;AUG 13, 1993 + Q +EXTKEY ; + N Y,% W @IOF,!,$G(SCDHD) D NOW^%DTC S Y=% W:$X>(IOM-40) ! W ?(IOM-40) + W $P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$E(Y,4,5))_" " W:Y#100 $J(Y#100\1,2)_"," W Y\10000+1700 W:Y#1 " "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12) + W ?(IOM-15),"PAGE: "_($G(DC)+1) + S Y="",$P(Y,"-",IOM)="" W !,Y,!! + W !,"Column Heading Explanation of column headings" + W ! + W !,"Patient Name Name of patient scheduled to be inactivated from their primary care team and position/provider." + W !,"SSN Patient's last 4 SSN numbers." + W !,"Institution Institution name, previously called Division, in which patient receives primary care." + W !,"PC Team The patient's assigned Primary Care team in PCMM." + W !,"Provider/ Name of Associate Primary Care Provider (AP) assigned to patient, if there is one." + W !," Team Position The name of the team position to which the Associate Primary Care Provider (AP) is assigned." + W !,"Current Preceptor/ Name of Primary Care Provider (PCP) assigned to patient. Every Primary Care patient should" + W !," Team Position be assigned to one PCP. The name of the team position to which the Primary Care Provider (PCP)" + W !," is assigned." + W !,"Date Scheduled for Date patient will be inactivated from PCMM and their Primary Care team and provider/position unless" + W !," Inactivation they have a completed outpatient appointment encounter with their current PCP or AP before this date." + W !," Note: There is a patient reassignment option, which allows an inactivated patient to be reactivated" + W !," to their previous Primary Care team and position if they return for care." + W !,"Reason for Extended The reason entered for extending the patient's time before inactivation from PC panels." + W !," Inactivation Entry of this field is in the PCMM GUI, Patient drop down menu, and the Extend Patient's Date for" + W !," Inactivation from PC Panels option." + Q +EXTCHUI ;roll n scroll option to extend a patient + N DA,DIC,DIE,DR,SCTM,SCARRAY,SCHIGH,SCX,V1 + S SCTM=0 F D P1 Q:+SCTM<1 + Q +P1 D GCL S DIC="^SCTM(404.51,",DIC(0)="AEQMZ" D ^DIC S SCTM=+Y Q:+SCTM<1 + W !,"Searching...",! + D EXTEND(.SCARRAY,SCTM) + I $G(^TMP("SCMCTSK9","OUT",$J,1))="" W !,"No Patients to Extend..." D GCL Q + S SCHIGH=$O(^TMP("SCMCTSK9","OUT",$J,9999999),-1) + S SCX=999 F Q:(SCX="^")!(SCX="") D P2 + Q +P2 W !,"Select From: ",!! + S V1=0 F S V1=$O(^TMP("SCMCTSK9","OUT",$J,V1)) Q:'V1 D + . W $J(V1,2)_" ",$P(^TMP("SCMCTSK9","OUT",$J,V1),U,3),! + F W !,"Select 1-",SCHIGH," " R SCX:DTIME Q:(SCX="^")!(SCX="")!((SCX'>SCHIGH)&(SCX>0)) D + . I $E(SCX,1)="?" W !,"Select 1-",SCHIGH," or '^' to exit" Q + . I (+SCX<1)!(+SCX>SCHIGH) W !,"Select a valid number" Q + I SCX'?1.9N Q + S DIE="^SCPT(404.43," + S DA=$P(^TMP("SCMCTSK9","OUT",$J,SCX),U) + S DR=".13//DO NOT EXTEND;S Y=.16 I X=4 S Y=.14;.14;.16////"_DUZ + D ^DIE + Q +EXTEND(DATA,SCTEAM) ;return list of patients to inactivate in next 60 days + ;IEN^POSITION^PATIENT^EXTENDED^REASON + K DATA,SCDATA,SDDATA + N CNT,I,J,K,A,POSA S CNT=1 S SCTEAM=$G(SCTEAM),^TMP("SCMCTSK9","OUT",$J,1)="" + D DT^DICRW S X="T-9M" D ^%DT S STDT=Y + S X="T-21M" D ^%DT S TYDT=+Y ;MAKE THIS 21 + S POSA="" + F S POSA=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA)) Q:POSA="" D + .F POS=0:0 S POS=$O(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS)) Q:'POS D POS +EX1 S A="^TMP(""SCMCTSK9"",$J)",CNT=1 F S A=$Q(@A) Q:A=""!($P(A,",",2)'=$J) D + .S B=@A + .S ^TMP("SCMCTSK9","OUT",$J,CNT)=(+$P(B,U,3))_U_$TR($P($P(A,"(",4),","),$C(34))_U_$TR($P(B,U,2),$C(34))_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,13)_U_$P($G(^SCPT(404.43,+$P(B,U,3),0)),U,14) + .S CNT=CNT+1 + Q +POS I '$$DATES^SCAPMCU1(404.59,POS) Q ;Not an active position + I '$P($G(^SCTM(404.57,POS,0)),U,4) Q ;Not PC + ;get patients for this position + K ^TMP("SC TMP LIST",$J) + S X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR) + S J=0 F S J=$O(@SCLIST@(J)) Q:'J S SCDATA=^(J) D + .N J I $P(SCDATA,U,4)>STDT Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,5) Q + .I '$P($G(^SCPT(404.43,+$P(SCDATA,U,3),0)),U,15) Q + .S DFN=+SCDATA + .D SEEN Q:SEEN + .S ^TMP("SCMCTSK9",$J,$P($G(^SCTM(404.57,POS,0)),U),$P(SCDATA,U,2),+SCDATA)=SCDATA,CNT=CNT+1 + K @SCLIST + Q +SEEN ;was patient seen + S SEEN=0 + N SCPRO,I,PRECP,PRO + N X,SCPRDTS,SCPR + ;get list of providers for this position + S PROV=+$$GETPRTP^SCAPMCU2(POS,DT) S SCPRO(+PROV)="" + S SCPRDTS("BEGIN")=TYDT + S SCPRDTS("END")=DT + S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR") + F I=0:0 S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="" + S PRECP=0 I $G(PREC),$G(PREC)'=POS S PRECP=+$$GETPRTP^SCAPMCU2(PREC,DT),SCPRO(+PRECP)="" + F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN + .F J=0:0 S J=$O(^SCE("ADFN",DFN,I,J)) Q:'J D Q:SEEN + ..N VISIT S VISIT=+$P($G(^SCE(J,0)),U,5) I $G(^SCE(J,0))<$G(TYDT) Q + ..F PRO=0:0 S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN + ...I $D(^SDD(409.44,"AO",J,$G(PRO))) S SEEN=1 Q ;GET THE PROVIDERJ + ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) S SEEN=1 Q + Q +GCL ;clean temp globals + K ^TMP("SCMCTSK9",$J) + K ^TMP("SCMCTSK9","OUT",$J) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMSVUT2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMSVUT2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCMSVUT2.m (revision 623) @@ -1,240 +1,240 @@ -SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99 - ;;5.3;Scheduling;**66,180,254,293,325,466,521**;AUG 13,1993;Build 1 - ;06/28/99 ACS Added CPT modifier validation - ; -COUNT(VALER) ;counts the number of errored encounters found. - ;INPUT VALER - The array containing the errors. - ;OUTPUT the number of errors - ; - N VAR,CNT - S VAR="",CNT=0 - F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 - Q CNT - ; -IPERR(VALER) ;counts the number of inpatient errored encounters found. - ;INPUT VALER - The array containing the errors. - ;OUTPUT the number of errors - ; - N VAR,CNT - S VAR="",CNT=0 - F S VAR=$O(@VALER@(VAR)) Q:VAR']"" D - .I $$INPATENC^SCDXUTL(VAR) S CNT=CNT+1 - Q CNT - ; -FILEVERR(PTR,VALERR) ;files the errors found for an encounter - ;INPUT PTR - The pointer to the entry in the transmission file 409.73 - ; VALERR - The array holding the errors for the encounter. - ;OUTPUT 0 - did not file - ; 1 - did file - N SEG,FILE - I '$D(VALERR) Q 0 - S SEG="",FILE=-1 - F S SEG=$O(@VALERR@(SEG)) Q:SEG']"" D FILE(VALERR,SEG,PTR,.FILE) - Q $S(FILE=1:1,1:0) - ; -FILE(VALERR,SEG,PTR,FILE) ; - N NBR - S NBR=0 - F S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR DO - .N CODPTR,CODE - .S CODE=$G(@VALERR@(SEG,NBR)) - .I CODE']"" Q - .S CODPTR=$O(^SD(409.76,"B",CODE,"")) - .I 'CODPTR Q - .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q - .S FILE=$$CRTERR^SCDXFU02(PTR,CODE) - .Q - Q - ; -VALWL(CLIN) ;WORKLOAD VALIDATION AT CHECK OUT - ;INPUT CLIN - IEN OF CLINIC - ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD - ; 1 - VALIDATE CLINIC WORKLOAD - N A1 - I '$D(CLIN) S CLIN=0 - S A1=$P($G(^SC(+CLIN,0)),U,30) - Q $S(A1=1:1,1:0) - ; -VALIDATE(XMITPTR) ;validates data that has a entry in the transmit file. - ; - ;INPUT XMITPTR - This is the point to an entry in file 409.73. - ; - ;OUTPUT -1 - the was a problem with the inputs - ; 0 - no errors were found - ; 1 - errors were found - ; - N VALERR,ERR,HL,HLEID,DFN - S ANS=-1 - S XMITPTR=+$G(XMITPTR) - I $G(^SD(409.73,XMITPTR,0))']"" G VALQ - D PATDFN^SCDXUTL2(XMITPTR) - ; - S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")" - ;Initialze HL7 variables - S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0)) - I ('HLEID) G VALQ - D INIT^HLFNC2(HLEID,.HL) - I ($O(HL(""))="") G VALQ - ; - S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR) - ; - I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0) - S ANS=0 - D DELAERR^SCDXFU02(XMITPTR,0) - D DEMUPDT(DFN,VALERR,"DEMO") - I $O(@VALERR@(0))]"" DO - .N FILE - .S ANS=1 - .S FILE=$$FILEVERR(XMITPTR,VALERR) - .Q - ; - K @VALERR,@HL7XMIT - ; -VALQ Q ANS - ; -DEMUPDT(DFN,VALERR,TYP) ; - ;This entry point updates all the other encoutners for this patient - ;that HAVE errors with a new set or demographic errors or deletes all - ;the demographic errors if none were found. - ;INPUT DFN - The patient's DFN - ; VALERR - errors to log - ; TYP - The type of errors to delete and log. - ; Right now demographic errors are the only kind "DEMO" - ; - S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR) - I DFN=""!(TYP="")!(VALERR="") Q - N PTRS,RNG,LP,PTR - S RNG=$P($T(@(TYP)),";;",2),PTRS="" - D CLEAN(DFN,RNG,.PTRS) - I '$D(@VALERR@("PID")) Q - I PTRS']"" Q - F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']"" DO - .I '$D(^SD(409.73,PTR,0)) Q - .N FILE - .D FILE(VALERR,"PID",PTR,.FILE) - .Q - Q - ; -CLEAN(DFN,RNG,PTRS) ;This subroutine cleans out all errors for a pateint - ;and returns a string of which entries in 409.73 were cleaned of errors - ; - N LP,COD,LP2,IEN - F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']"" I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']"" DO - .N VAR,RES - .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^" - .I $P(VAR,U,1)="" S PTR="" Q - .S RES=$$DELERR^SCDXFU02(IEN) - .I PTRS[VAR Q - .S PTRS=PTRS_VAR - .Q - Q - ; -MODCODE(DATA,ENCDT) ; - ; - ;--------------------------------------------------------------- - ; VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION - ; - ; INPUT: DATA - The procedure and modifier code to be checked - ; format: CPT~modifier - ; ENCDT - The date of the encounter - ; - ;OUTPUT: 1 - valid modifier and CPT+modifier combination - ; 0 - invalid modifier or CPT+modifier combination - ; - ;**NOTE** This call makes the assumption that leading zeros are - ; intact in the input. - ;--------------------------------------------------------------- - ; - ;- validate modifier only - N DATAMOD - S DATAMOD=$P(DATA,"~",2) - I '$D(DATAMOD) Q 0 - I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0 - ; - ;- validate CPT+modifier pair - N DATAPROC - S DATAPROC=$P(DATA,"~",1) - I '$D(DATAPROC) Q 0 - I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0 - Q 1 - ; -MODMETH(DATA) ; - ; - ;--------------------------------------------------------------- - ; VALIDATE MODIFIER CODING METHOD - ; - ; INPUT: DATA - The modifier coding method to be checked - ; - ;OUTPUT: 1 - valid modifier coding method - ; 0 - invalid modifier coding method - ; - ; Valid modifier coding methods: C and H - ;--------------------------------------------------------------- - ; - I '$D(DATA) Q 0 - S DATA=","_DATA_"," - I ",C,H,"'[DATA Q 0 - Q 1 - ; -ETHNIC(DATA) ; - ;INPUT DATA - the ethnicity code to be validated (NNNN-C-XXX) - ; - N VAL,MTHD - I '$D(DATA) Q 0 - I DATA="" Q 1 - S VAL=$P(DATA,"-",1,2) - S MTHD=$P(DATA,"-",3) - I VAL'?4N1"-"1N Q 0 - I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0 - Q 1 -CONFDT(DATA,SUB) ;CONFIDENTIAL ADDRESS START/STOP DATE - N X,Y,%DT,DTOUT,STDT,ENDT - I '$D(DATA) Q 0 - S STDT=$P(DATA,SUB,1) - S ENDT=$P(DATA,SUB,2) - I STDT="" Q 0 - S STDT=$$FMDATE^HLFNC(STDT) - S X=STDT,%DT="X" D ^%DT I Y=-1 Q 0 ;SD/521 added %DT - I ENDT="" Q 1 - S ENDT=$$FMDATE^HLFNC(ENDT) - S X=ENDT,%DT="X" D ^%DT I Y=-1 Q 0 ;SD/521 added %DT - I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0 - Q 1 - ; -CONFCAT(DATA) ;CONFIDENTIAL ADDRESS CATEGORY TYPE - I '$D(DATA) Q 0 - I DATA="" Q 0 - N VAL,GOOD - S GOOD=0 - F VAL="VACAA","VACAC","VACAE","VACAM","VACAO" I DATA=VAL S GOOD=1 Q - Q GOOD - ; -CVEDT(DATA) ;Combat vet end date (ZEL.38) - ;Input : DATA - CombatVetIndicator ^ CombatVetEndDate - ;Output : 1 = Good / 0 = Bad - ; - N CVI,CVEDT - S DATA=$G(DATA) - S CVI=$P(DATA,"^",1) - S CVEDT=$P(DATA,"^",2) - I 'CVI Q $S(CVEDT="":1,1:0) - Q CVEDT?8N - ; -CLCV(DATA,SDOE) ;Cross check for combat vet classification question - ;Input : DATA - Answer to classification question - ; SDOE - Pointer to encounter (file # 409.68) - ;Output : 1 = Good / 0 = Bad - ; - S DATA=$G(DATA) - Q:(DATA'=1) 1 - N VET,SDDT,SDOE0 - S SDOE=$G(SDOE) Q:'SDOE 0 - S SDOE0=$G(^SCE(SDOE,0)) - S SDDT=+SDOE0 Q:'SDDT 0 - S DFN=+$P(SDOE0,"^",2) Q:'DFN 0 - S VET=$P($$EL^SDCO22(DFN,SDOE),"^",5) - I VET'="Y" Q 0 - S VET=+$$CVEDT^DGCV(DFN,SDDT) - Q $S(VET=1:1,1:0) - ; -DEMO ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360 +SCMSVUT2 ;ALB/JLU;Utility routine for AMBCARE;06/28/99 + ;;5.3;Scheduling;**66,180,254,293,325,466**;AUG 13,1993;Build 2 + ;06/28/99 ACS Added CPT modifier validation + ; +COUNT(VALER) ;counts the number of errored encounters found. + ;INPUT VALER - The array containing the errors. + ;OUTPUT the number of errors + ; + N VAR,CNT + S VAR="",CNT=0 + F S VAR=$O(@VALER@(VAR)) Q:VAR']"" S CNT=CNT+1 + Q CNT + ; +IPERR(VALER) ;counts the number of inpatient errored encounters found. + ;INPUT VALER - The array containing the errors. + ;OUTPUT the number of errors + ; + N VAR,CNT + S VAR="",CNT=0 + F S VAR=$O(@VALER@(VAR)) Q:VAR']"" D + .I $$INPATENC^SCDXUTL(VAR) S CNT=CNT+1 + Q CNT + ; +FILEVERR(PTR,VALERR) ;files the errors found for an encounter + ;INPUT PTR - The pointer to the entry in the transmission file 409.73 + ; VALERR - The array holding the errors for the encounter. + ;OUTPUT 0 - did not file + ; 1 - did file + N SEG,FILE + I '$D(VALERR) Q 0 + S SEG="",FILE=-1 + F S SEG=$O(@VALERR@(SEG)) Q:SEG']"" D FILE(VALERR,SEG,PTR,.FILE) + Q $S(FILE=1:1,1:0) + ; +FILE(VALERR,SEG,PTR,FILE) ; + N NBR + S NBR=0 + F S NBR=$O(@VALERR@(SEG,NBR)) Q:'NBR DO + .N CODPTR,CODE + .S CODE=$G(@VALERR@(SEG,NBR)) + .I CODE']"" Q + .S CODPTR=$O(^SD(409.76,"B",CODE,"")) + .I 'CODPTR Q + .I $D(^SD(409.75,"AER",PTR,CODPTR)) S FILE=1 Q + .S FILE=$$CRTERR^SCDXFU02(PTR,CODE) + .Q + Q + ; +VALWL(CLIN) ;WORKLOAD VALIDATION AT CHECK OUT + ;INPUT CLIN - IEN OF CLINIC + ;OUTPUT 0 - DO NOT VALIDATE WORKLOAD + ; 1 - VALIDATE CLINIC WORKLOAD + N A1 + I '$D(CLIN) S CLIN=0 + S A1=$P($G(^SC(+CLIN,0)),U,30) + Q $S(A1=1:1,1:0) + ; +VALIDATE(XMITPTR) ;validates data that has a entry in the transmit file. + ; + ;INPUT XMITPTR - This is the point to an entry in file 409.73. + ; + ;OUTPUT -1 - the was a problem with the inputs + ; 0 - no errors were found + ; 1 - errors were found + ; + N VALERR,ERR,HL,HLEID,DFN + S ANS=-1 + S XMITPTR=+$G(XMITPTR) + I $G(^SD(409.73,XMITPTR,0))']"" G VALQ + D PATDFN^SCDXUTL2(XMITPTR) + ; + S HL7XMIT="^TMP(""HLS"","_$J_")",VALERR="^TMP(""SCDXVALID"","_$J_","_XMITPTR_")" + ;Initialze HL7 variables + S HLEID=+$O(^ORD(101,"B","SCDX AMBCARE SEND SERVER FOR ADT-Z00",0)) + I ('HLEID) G VALQ + D INIT^HLFNC2(HLEID,.HL) + I ($O(HL(""))="") G VALQ + ; + S ERR=$$BUILDHL7^SCDXMSG0(XMITPTR,.HL,1,HL7XMIT,1,VALERR) + ; + I ERR<0,$O(@VALERR@(0))']"" D VALIDATE^SCMSVUT0("INTERNAL","","V900",VALERR,0) + S ANS=0 + D DELAERR^SCDXFU02(XMITPTR,0) + D DEMUPDT(DFN,VALERR,"DEMO") + I $O(@VALERR@(0))]"" DO + .N FILE + .S ANS=1 + .S FILE=$$FILEVERR(XMITPTR,VALERR) + .Q + ; + K @VALERR,@HL7XMIT + ; +VALQ Q ANS + ; +DEMUPDT(DFN,VALERR,TYP) ; + ;This entry point updates all the other encoutners for this patient + ;that HAVE errors with a new set or demographic errors or deletes all + ;the demographic errors if none were found. + ;INPUT DFN - The patient's DFN + ; VALERR - errors to log + ; TYP - The type of errors to delete and log. + ; Right now demographic errors are the only kind "DEMO" + ; + S DFN=$G(DFN),TYP=$G(TYP),VALERR=$G(VALERR) + I DFN=""!(TYP="")!(VALERR="") Q + N PTRS,RNG,LP,PTR + S RNG=$P($T(@(TYP)),";;",2),PTRS="" + D CLEAN(DFN,RNG,.PTRS) + I '$D(@VALERR@("PID")) Q + I PTRS']"" Q + F LP=1:1 S PTR=$P(PTRS,U,LP) Q:PTR']"" DO + .I '$D(^SD(409.73,PTR,0)) Q + .N FILE + .D FILE(VALERR,"PID",PTR,.FILE) + .Q + Q + ; +CLEAN(DFN,RNG,PTRS) ;This subroutine cleans out all errors for a pateint + ;and returns a string of which entries in 409.73 were cleaned of errors + ; + N LP,COD,LP2,IEN + F LP=1:1 S COD=$P(RNG,U,LP) Q:COD']"" I $D(^SD(409.75,"ACOD",DFN,COD)) S IEN="" F LP2=1:1 S IEN=$O(^SD(409.75,"ACOD",DFN,COD,IEN)) Q:IEN']"" DO + .N VAR,RES + .S VAR=$P($G(^SD(409.75,IEN,0)),U,1)_"^" + .I $P(VAR,U,1)="" S PTR="" Q + .S RES=$$DELERR^SCDXFU02(IEN) + .I PTRS[VAR Q + .S PTRS=PTRS_VAR + .Q + Q + ; +MODCODE(DATA,ENCDT) ; + ; + ;--------------------------------------------------------------- + ; VALIDATE MODIFIER AND CPT+MODIFIER COMBINATION + ; + ; INPUT: DATA - The procedure and modifier code to be checked + ; format: CPT~modifier + ; ENCDT - The date of the encounter + ; + ;OUTPUT: 1 - valid modifier and CPT+modifier combination + ; 0 - invalid modifier or CPT+modifier combination + ; + ;**NOTE** This call makes the assumption that leading zeros are + ; intact in the input. + ;--------------------------------------------------------------- + ; + ;- validate modifier only + N DATAMOD + S DATAMOD=$P(DATA,"~",2) + I '$D(DATAMOD) Q 0 + I $$MOD^ICPTMOD(DATAMOD,"E",ENCDT,1)'>0 Q 0 + ; + ;- validate CPT+modifier pair + N DATAPROC + S DATAPROC=$P(DATA,"~",1) + I '$D(DATAPROC) Q 0 + I $$MODP^ICPTMOD(DATAPROC,DATAMOD,"E",ENCDT,1)'>0 Q 0 + Q 1 + ; +MODMETH(DATA) ; + ; + ;--------------------------------------------------------------- + ; VALIDATE MODIFIER CODING METHOD + ; + ; INPUT: DATA - The modifier coding method to be checked + ; + ;OUTPUT: 1 - valid modifier coding method + ; 0 - invalid modifier coding method + ; + ; Valid modifier coding methods: C and H + ;--------------------------------------------------------------- + ; + I '$D(DATA) Q 0 + S DATA=","_DATA_"," + I ",C,H,"'[DATA Q 0 + Q 1 + ; +ETHNIC(DATA) ; + ;INPUT DATA - the ethnicity code to be validated (NNNN-C-XXX) + ; + N VAL,MTHD + I '$D(DATA) Q 0 + I DATA="" Q 1 + S VAL=$P(DATA,"-",1,2) + S MTHD=$P(DATA,"-",3) + I VAL'?4N1"-"1N Q 0 + I ",SLF,UNK,PRX,OBS,"'[MTHD Q 0 + Q 1 +CONFDT(DATA,SUB) ;CONFIDENTIAL ADDRESS START/STOP DATE + N X,Y,%DT,DTOUT,STDT,ENDT + I '$D(DATA) Q 0 + S STDT=$P(DATA,SUB,1) + S ENDT=$P(DATA,SUB,2) + I STDT="" Q 0 + S STDT=$$FMDATE^HLFNC(STDT) + S X=STDT D ^%DT I Y=-1 Q 0 + I ENDT="" Q 1 + S ENDT=$$FMDATE^HLFNC(ENDT) + S X=ENDT D ^%DT I Y=-1 Q 0 + I $$FMDIFF^XLFDT(ENDT,STDT,1)<0 Q 0 + Q 1 + ; +CONFCAT(DATA) ;CONFIDENTIAL ADDRESS CATEGORY TYPE + I '$D(DATA) Q 0 + I DATA="" Q 0 + N VAL,GOOD + S GOOD=0 + F VAL="VACAA","VACAC","VACAE","VACAM","VACAO" I DATA=VAL S GOOD=1 Q + Q GOOD + ; +CVEDT(DATA) ;Combat vet end date (ZEL.38) + ;Input : DATA - CombatVetIndicator ^ CombatVetEndDate + ;Output : 1 = Good / 0 = Bad + ; + N CVI,CVEDT + S DATA=$G(DATA) + S CVI=$P(DATA,"^",1) + S CVEDT=$P(DATA,"^",2) + I 'CVI Q $S(CVEDT="":1,1:0) + Q CVEDT?8N + ; +CLCV(DATA,SDOE) ;Cross check for combat vet classification question + ;Input : DATA - Answer to classification question + ; SDOE - Pointer to encounter (file # 409.68) + ;Output : 1 = Good / 0 = Bad + ; + S DATA=$G(DATA) + Q:(DATA'=1) 1 + N VET,SDDT,SDOE0 + S SDOE=$G(SDOE) Q:'SDOE 0 + S SDOE0=$G(^SCE(SDOE,0)) + S SDDT=+SDOE0 Q:'SDDT 0 + S DFN=+$P(SDOE0,"^",2) Q:'DFN 0 + S VET=$P($$EL^SDCO22(DFN,SDOE),"^",5) + I VET'="Y" Q 0 + S VET=+$$CVEDT^DGCV(DFN,SDDT) + Q $S(VET=1:1,1:0) + ; +DEMO ;;2000^2030^2050^2100^2150^2200^2210^2220^2230^2240^2250^2300^2330^2360 Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPBK11.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPBK11.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPBK11.m (revision 623) @@ -1,97 +1,97 @@ -SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96 - ;;5.3;Scheduling;**41,520**;AUG 13, 1993;Build 26 - ; -GETSEL(SCDATA,SCTYPE,SCIEN) ; - ; -- get SELECTION entity data for details form - ; - ; input: SCTYPE := type of autolink (DIVISIOND, TEAM, ectc.) - ; SCIEN := ien of entity - ; output: SCDATA(1..n) := info about entity - ; - ; -- SEE BOTTOM OF SCRPBK FOR VARIABLE DEFINITIONS - ; - ; Related RPC: SCRP FILE ENTRY GETSELECTION - ; - N SC0,SCI,SCINC - S SCINC=0,SCID=+SCIEN - ; - IF SCTYPE="DIVISION" D DIV G GETSELQ - ; - IF SCTYPE="TEAM" D TEAM G GETSELQ - ; - IF SCTYPE="PRACTITIONER" D PRAC G GETSELQ - ; - IF SCTYPE="ROLE" D ROLE G GETSELQ - ; - IF SCTYPE="CLINIC" D CLIN G GETSELQ - ; - IF SCTYPE="USERCLASS" D USER G GETSELQ - ; -GETSELQ Q - ; -SET(X,INC,SCDATA) ; -- set value in return array - S INC=$G(INC)+1,SCDATA(INC)=X - Q - ; -DIV ; -- get division details - D SET("Teams in Division:",.SCINC,.SCDATA) - D SET("------------------",.SCINC,.SCDATA) - S SCI=0 F S SCI=$O(^SCTM(404.51,"AINST",SCID,SCI)) Q:'SCI D - . D SET($P($G(^SCTM(404.51,SCI,0)),U),.SCINC,.SCDATA) - Q - ; -TEAM ; -- get team description - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=404.51,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",",50,"","SC") - D SET("Team Description:",.SCINC,.SCDATA) - D SET("-----------------",.SCINC,.SCDATA) - IF $O(SC(SCFLE,SCIEN,50,0)) D - . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,50,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,50,SCI) D - . . D SET(X,.SCINC,.SCDATA) - ELSE D - . D SET(SCDEF,.SCINC,.SCDATA) - Q - ; -PRAC ; -- get practitioner details - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=200,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",","1;8;28","","SC") - D SET(" Initials: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) - D SET("Mail Code: "_$S($G(SC(SCFLE,SCIEN,28))]"":SC(SCFLE,SCIEN,28),1:SCDEF),.SCINC,.SCDATA) - D SET(" Title: "_$S($G(SC(SCFLE,SCIEN,8))]"":SC(SCFLE,SCIEN,8),1:SCDEF),.SCINC,.SCDATA) - Q - ; -ROLE ; -- get standard role description - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=403.46,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",",1,"","SC") - D SET("Role Description:",.SCINC,.SCDATA) - D SET("-----------------",.SCINC,.SCDATA) - IF $O(SC(SCFLE,SCIEN,1,0)) D - . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,1,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,1,SCI) D - . . D SET(X,.SCINC,.SCDATA) - ELSE D - . D SET(SCDEF,.SCINC,.SCDATA) - Q - ; -CLIN ; -- get clinic details - N SC,SCFLE,SCIEN,SCDEF - S SCFLE=44,SCIEN=SCID_",",SCDEF="" - D GETS^DIQ(SCFLE,SCID_",","1;3.5","","SC") - D SET("Abbreviation: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) - D SET(" Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA) - D SET(" ",.SCINC,.SCDATA) - D SET("Associated Teams and Positions:",.SCINC,.SCDATA) - D SET("-------------------------------",.SCINC,.SCDATA) - S SCI=0 F S SCI=$O(^SCTM(404.57,"E",SCID,SCI)) Q:'SCI D - . S X=$G(^SCTM(404.57,SCI,0)) - . D SET(" Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA) - . D SET(" Position: "_$P(X,U),.SCINC,.SCDATA) - . D SET(" ",.SCINC,.SCDATA) - Q - ; -USER ; -- get user class details - D SET("No additional information available at this time. ",.SCINC,.SCDATA) - Q - ; +SCRPBK11 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96 + ;;5.3;Scheduling;**41**;AUG 13, 1993 + ; +GETSEL(SCDATA,SCTYPE,SCIEN) ; + ; -- get SELECTION entity data for details form + ; + ; input: SCTYPE := type of autolink (DIVISIOND, TEAM, ectc.) + ; SCIEN := ien of entity + ; output: SCDATA(1..n) := info about entity + ; + ; -- SEE BOTTOM OF SCRPBK FOR VARIABLE DEFINITIONS + ; + ; Related RPC: SCRP FILE ENTRY GETSELECTION + ; + N SC0,SCI,SCINC + S SCINC=0,SCID=+SCIEN + ; + IF SCTYPE="DIVISION" D DIV G GETSELQ + ; + IF SCTYPE="TEAM" D TEAM G GETSELQ + ; + IF SCTYPE="PRACTITIONER" D PRAC G GETSELQ + ; + IF SCTYPE="ROLE" D ROLE G GETSELQ + ; + IF SCTYPE="CLINIC" D CLIN G GETSELQ + ; + IF SCTYPE="USERCLASS" D USER G GETSELQ + ; +GETSELQ Q + ; +SET(X,INC,SCDATA) ; -- set value in return array + S INC=$G(INC)+1,SCDATA(INC)=X + Q + ; +DIV ; -- get division details + D SET("Teams in Division:",.SCINC,.SCDATA) + D SET("------------------",.SCINC,.SCDATA) + S SCI=0 F S SCI=$O(^SCTM(404.51,"AINST",SCID,SCI)) Q:'SCI D + . D SET($P($G(^SCTM(404.51,SCI,0)),U),.SCINC,.SCDATA) + Q + ; +TEAM ; -- get team description + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=404.51,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",",50,"","SC") + D SET("Team Description:",.SCINC,.SCDATA) + D SET("-----------------",.SCINC,.SCDATA) + IF $O(SC(SCFLE,SCIEN,50,0)) D + . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,50,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,50,SCI) D + . . D SET(X,.SCINC,.SCDATA) + ELSE D + . D SET(SCDEF,.SCINC,.SCDATA) + Q + ; +PRAC ; -- get practitioner details + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=200,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",","1;8;28","","SC") + D SET(" Initials: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) + D SET("Mail Code: "_$S($G(SC(SCFLE,SCIEN,28))]"":SC(SCFLE,SCIEN,28),1:SCDEF),.SCINC,.SCDATA) + D SET(" Title: "_$S($G(SC(SCFLE,SCIEN,8))]"":SC(SCFLE,SCIEN,8),1:SCDEF),.SCINC,.SCDATA) + Q + ; +ROLE ; -- get standard role description + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=403.46,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",",1,"","SC") + D SET("Role Description:",.SCINC,.SCDATA) + D SET("-----------------",.SCINC,.SCDATA) + IF $O(SC(SCFLE,SCIEN,1,0)) D + . S SCI=0 F S SCI=$O(SC(SCFLE,SCIEN,1,SCI)) Q:'SCI S X=SC(SCFLE,SCIEN,1,SCI) D + . . D SET(X,.SCINC,.SCDATA) + ELSE D + . D SET(SCDEF,.SCINC,.SCDATA) + Q + ; +CLIN ; -- get clinic details + N SC,SCFLE,SCIEN,SCDEF + S SCFLE=44,SCIEN=SCID_",",SCDEF="" + D GETS^DIQ(SCFLE,SCID_",","1;3.5","","SC") + D SET("Abbreviation: "_$S($G(SC(SCFLE,SCIEN,1))]"":SC(SCFLE,SCIEN,1),1:SCDEF),.SCINC,.SCDATA) + D SET(" Division: "_$S($G(SC(SCFLE,SCIEN,3.5))]"":SC(SCFLE,SCIEN,3.5),1:SCDEF),.SCINC,.SCDATA) + D SET(" ",.SCINC,.SCDATA) + D SET("Assoicated Teams and Positions:",.SCINC,.SCDATA) + D SET("-------------------------------",.SCINC,.SCDATA) + S SCI=0 F S SCI=$O(^SCTM(404.57,"D",SCID,SCI)) Q:'SCI D + . S X=$G(^SCTM(404.57,SCI,0)) + . D SET(" Team: "_$P($G(^SCTM(404.51,+$P(X,U,2),0)),U),.SCINC,.SCDATA) + . D SET(" Position: "_$P(X,U),.SCINC,.SCDATA) + . D SET(" ",.SCINC,.SCDATA) + Q + ; +USER ; -- get user class details + D SET("No additional information available at this time. ",.SCINC,.SCDATA) + Q + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC.m (revision 623) @@ -1,100 +1,104 @@ -SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,140,174,177,431,526,520**;AUG 13, 1993;Build 26 - ; - ;Detailed Listing of Patients and Their Enrolled Clinics Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary - ;Care, and Print device - ; - N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT - K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions - W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR - W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q - ; -QUE(INST,TEAM,CLINIC,ASSUN) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;CLINIC - clinics selected (variable and array) - ;ASSUN - Assigned or Unassigned to PC - N ZTSAVE,II - F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;CLINIC - clinics selected (variable and array) - ;ASSUN - Assigned or Unassigned to PC - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPEC" - S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP - N II - F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S VAUTTN="" - S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC") - S STORE="^TMP("_$J_",""SCRPEC"")" - K @STORE - S @STORE=0 - D FIND^SCRPEC3 - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP - Q -EXIT2 ; - K @STORE - K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP - Q - ; -PDATA(DFN,CLNEN,CNAME,FLAG) ; - ;Collect and format data for report - ; - N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT - S DATA="" - S NODE=$G(^DPT(DFN,0)) - S NAME=$P(NODE,"^") ;patient name - S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s - S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4) ;means test status SD*5.3*431 - S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility - S PSTAT="N/A" - S STATD="" - S LAST=$$GETLAST^SCRPU3(DFN,.CLNEN) ;last Clinic appointment - S NEXT=$$GETNEXT^SCRPU3(DFN,.CLNEN) ;next clinic appointment - ;I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) - I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,12)_"^"_DATA - I $D(FLAG) S DATA=$E(NAME,1,12)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT - Q DATA - ; +SCRPEC ;ALB/CMM - Detail List of Pts & Enroll Clinics ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,140,174,177,431**;AUG 13, 1993 + ; + ;Detailed Listing of Patients and Their Enrolled Clinics Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Clinic, Assigned or Unassigned to Primary + ;Care, and Print device + ; + N VAUTD,VAUTT,VAUTC,VAUTA,QTIME,PRNT + K VAUTD,VAUTT,VAUTC,VAUTA,VAUTCA,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + ;S VAUTCA="" ;allows for selection of any clinic in one of the selected divisions + W ! K Y D CLINIC^SCRPU1 I '$D(VAUTC) G ERR + W ! K Y D ASSUN^SCRPU2 I '$D(VAUTA) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTC,.VAUTA) Q + ; +QUE(INST,TEAM,CLINIC,ASSUN) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;CLINIC - clinics selected (variable and array) + ;ASSUN - Assigned or Unassigned to PC + N ZTSAVE,II + F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPEC","Detailed Patient Enrollments",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,CLINIC,ASSUN,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;CLINIC - clinics selected (variable and array) + ;ASSUN - Assigned or Unassigned to PC + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(CLINIC)!'$D(ASSUN)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPEC" + S ZTDESC="Detailed Patient List & Enrolled Clinics",ZTIO=IOP + N II + F II="INST","TEAM","CLINIC","ASSUN","INST(","TEAM(","CLINIC(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S VAUTTN="" + S TITL="Detailed Patient Assignments - "_$S(ASSUN=1:"Assigned PC",1:"Not Assigned PC") + S STORE="^TMP("_$J_",""SCRPEC"")" + K @STORE + S @STORE=0 + D FIND^SCRPEC3 + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D HEADER^SCRPEC2,PRINTIT^SCRPEC3(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTSAVE,ZTSK,ZTIO,ZTDTH,ZTRTN,ZTDESC,VAUTCA,SCUP + Q +EXIT2 ; + K @STORE + K STORE,VAUTTN,PAGE,TITL,IOP,TITL,NODATA,CLINIC,ASSUN,INST,TEAM,STOP + Q + ; +PDATA(DFN,CLNEN,FLAG) ; + ;Collect and format data for report + ; + N NODE,NAME,PID,PELIG,MT,PSTAT,STATD,DATA,LAST,NEXT,CEN,CNAME + S DATA="" + S NODE=$G(^DPT(DFN,0)) + S NAME=$P(NODE,"^") ;patient name + S PID=$P($G(^DPT(DFN,.36)),"^",3),PID=$TR(PID,"-","") ;PID without '-'s + S MT=$$LST^DGMTU(DFN),MT=$P(MT,"^",4) ;means test status SD*5.3*431 + S PELIG=$$ELIG^SCRPU3(DFN) ;primary eligibility + ; + S CNAME=$P($G(^SC(CLNEN,0)),"^") + S CEN=+$O(^DPT(DFN,"DE","B",CLNEN,"")) + S NODE=$G(^DPT(DFN,"DE",CEN,1,1,0)) + S PSTAT=$P(NODE,"^",2) S PSTAT=PSTAT_$S(PSTAT="A":"C",PSTAT="O":"PT",1:"") ;opt or ac status + I $P(NODE,"^")="" S STATD="" + I $P(NODE,"^")'="" S STATD=$TR($$FMTE^XLFDT($P(NODE,"^"),"5DF")," ","0") ;enrollment date + S LAST=$$GETLAST^SCRPU3(DFN,CLNEN) ;last clinic appointment + S NEXT=$$GETNEXT^SCRPU3(DFN,CLNEN) ;next clinic appointment + I '$D(FLAG) S DATA=$$FORMAT^SCRPEC2(NAME,PID,MT,PELIG,PSTAT,STATD,LAST,NEXT,CNAME),DATA=$E(NAME,1,20)_"^"_DATA + I $D(FLAG) S DATA=$E(NAME,1,20)_"^"_PID_"^"_MT_"^"_PELIG_"^"_PSTAT_"^"_STATD_"^"_LAST_"^"_NEXT + Q DATA + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPEC2.m (revision 623) @@ -1,157 +1,157 @@ -SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,140,174,177,526**;AUG 13, 1993;Build 8 - ; - ;Detailed Listing of Patients and Their Enrolled Clinics Report - ; -PAT(TIEN,PTLIST) ; - ;TIEN - team ien - ;PTLIST - array holding patients assigned to team TIEN - ; - N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC - S ENT=0,CLLIST="LIST2",ERR="ERROR2" - K @CLLIST - F S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N) D - .S NODE=$G(@PTLIST@(ENT)) - .Q:NODE="" - .S PTIEN=+$P(NODE,"^") ;patient ien - .S PC=$$PCASSIGN(PTIEN,TIEN) - .Q:PC'=ASSUN ;not selected assigned/unassigned primary care - .K @CLLIST - .S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR) - .;all clinics for patient PTIEN - .Q:'OKAY - .D KEEP(TIEN,PTIEN,.CLLIST) - K @CLLIST - Q - ; -KEEP(TIEN,PTIEN,CLLIST) ;keep data for report - ;TIEN - team ien - ;PTIEN - patient ien - ;CLLIST - array holding clinics for patient PTIEN - ; - N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME - N SCPCPR,SCPCAP,SCI,PCLIST - S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name - S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien - S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name - S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name - K ^TMP("SC",$J,PTIEN) - S SCI=$$GETALL^SCAPMCA(PTIEN) D - .;Name of PC Provider - .S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2) - .;Name of Associate Provider - .S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2) - .Q - ; - S ENT=0 - F S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N) D - .S NODE=$G(@CLLIST@(ENT)) - .S CIEN=+$P(NODE,"^") ;clinic ien - .I CLINIC'=1,'$D(CLINIC(CIEN)) Q - .S CNAME=$P(NODE,"^",2) ;clinic name - .D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) - .S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1) - .S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP - .;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. - .D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) - Q - ; -SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ; - ;INS - institution ien - ;INAME - institution name - ;TIEN - team ien - ;TNAME - team name - ;PTIEN - patient ien - ;PNAME - patient name - ;CIEN - clinic ien - ;CNAME - clinic name - ; - I INAME="" S INAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - I CNAME="" S CNAME="[BAD DATA]" - I PNAME="" S PNAME="[BAD DATA]" - I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME - I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME - I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN) - I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)="" - Q - ; -PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care - ;DFN - patient ien - ;TIEN - team ien - ;1 - yes - ;0 - no - ; - N ADATE,ENTRY,PC - S PC=0 - I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC - S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date - S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien - I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1 - Q PC - ; -HEADER ;report column titles - N HLD - S HLD="H0" - S $E(@STORE@("SUBHEADER",HLD),25)="M.T." - S $E(@STORE@("SUBHEADER",HLD),31)="Prim" - ;Removed by patch 174 - ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat" - ;S $E(@STORE@("SUBHEADER",HLD),36)="Status" - S $E(@STORE@("SUBHEADER",HLD),42)="Last" - S $E(@STORE@("SUBHEADER",HLD),54)="Next" - S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled" - S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care" - S $E(@STORE@("SUBHEADER",HLD),115)="Associate" - S HLD="H1" - S @STORE@("SUBHEADER",HLD)="Patient Name" - S $E(@STORE@("SUBHEADER",HLD),16)="Pt ID" - S $E(@STORE@("SUBHEADER",HLD),25)="Stat" - S $E(@STORE@("SUBHEADER",HLD),31)="Elig" - ;Removed by patch 174 - ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat" - ;S $E(@STORE@("SUBHEADER",HLD),36)="Date" - S $E(@STORE@("SUBHEADER",HLD),42)="Appt" - S $E(@STORE@("SUBHEADER",HLD),54)="Appt" - S $E(@STORE@("SUBHEADER",HLD),66)="Clinic" - S $E(@STORE@("SUBHEADER",HLD),95)="Provider" - S $E(@STORE@("SUBHEADER",HLD),115)="Provider" - S HLD="H2" - S $P(@STORE@("SUBHEADER",HLD),"=",133)="" - Q - ; -FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report - ;PTIEN - patient ien - ;INS - institution ien - ;TIEN - team ien - ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. - ;CNAME - clinic name - ;CIEN - clinic ien - ; - S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,12) ;patient name - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),14)=$P(PDATA,"^",2) ;primary long id 9 digit - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),26)=$P(PDATA,"^",3) ;means test category - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility - ;Removed by patch 174 - ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status - ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov. - S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov. - Q - ; -CHEAD(INS,TEAM,CLINIC) ; - ;column headings - ; - N EN,NEWP - W ! - S NEWP=0 - I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1 - I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1 - I STOP Q - I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),! -CH2 F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN)) - Q - ; +SCRPEC2 ;ALB/CMM - Detail List of Pts & Enroll Clinics Continued ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,140,174,177**;AUG 13, 1993 + ; + ;Detailed Listing of Patients and Their Enrolled Clinics Report + ; +PAT(TIEN,PTLIST) ; + ;TIEN - team ien + ;PTLIST - array holding patients assigned to team TIEN + ; + N PTIEN,ENT,NODE,OKAY,CLLIST,ERR,PC + S ENT=0,CLLIST="LIST2",ERR="ERROR2" + K @CLLIST + F S ENT=$O(@PTLIST@(ENT)) Q:ENT=""!(ENT'?.N) D + .S NODE=$G(@PTLIST@(ENT)) + .Q:NODE="" + .S PTIEN=+$P(NODE,"^") ;patient ien + .S PC=$$PCASSIGN(PTIEN,TIEN) + .Q:PC'=ASSUN ;not selected assigned/unassigned primary care + .K @CLLIST + .S OKAY=$$CLPT^SCAPMC29(PTIEN,"","",.CLLIST,.ERR) + .;all clinics for patient PTIEN + .Q:'OKAY + .D KEEP(TIEN,PTIEN,.CLLIST) + K @CLLIST + Q + ; +KEEP(TIEN,PTIEN,CLLIST) ;keep data for report + ;TIEN - team ien + ;PTIEN - patient ien + ;CLLIST - array holding clinics for patient PTIEN + ; + N ENT,TNAME,INS,NODE,INAME,PDATA,NODE,CIEN,CNAME,PNAME + N SCPCPR,SCPCAP,SCI,PCLIST + S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name + S INS=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien + S INAME=$P($G(^DIC(4,INS,0)),"^") ;institution name + S PNAME=$P($G(^DPT(PTIEN,0)),"^") ;patient name + K ^TMP("SC",$J,PTIEN) + S SCI=$$GETALL^SCAPMCA(PTIEN) D + .;Name of PC Provider + .S SCPCPR=$P($G(^TMP("SC",$J,PTIEN,"PCPR",1)),U,2) + .;Name of Associate Provider + .S SCPCAP=$P($G(^TMP("SC",$J,PTIEN,"PCAP",1)),U,2) + .Q + ; + S ENT=0 + F S ENT=$O(@CLLIST@(ENT)) Q:ENT=""!(ENT'?.N) D + .S NODE=$G(@CLLIST@(ENT)) + .S CIEN=+$P(NODE,"^") ;clinic ien + .I CLINIC'=1,'$D(CLINIC(CIEN)) Q + .S CNAME=$P(NODE,"^",2) ;clinic name + .D SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) + .S PDATA=$$PDATA^SCRPEC(PTIEN,CIEN,1) + .S $P(PDATA,U,9)=SCPCPR,$P(PDATA,U,10)=SCPCAP + .;name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. + .D FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) + Q + ; +SETUP(INS,INAME,TIEN,TNAME,PTIEN,PNAME,CIEN,CNAME) ; + ;INS - institution ien + ;INAME - institution name + ;TIEN - team ien + ;TNAME - team name + ;PTIEN - patient ien + ;PNAME - patient name + ;CIEN - clinic ien + ;CNAME - clinic name + ; + I INAME="" S INAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + I CNAME="" S CNAME="[BAD DATA]" + I PNAME="" S PNAME="[BAD DATA]" + I '$D(@STORE@("I",INAME,INS)) S @STORE@("I",INAME,INS)="",@STORE@(INS)="Division: "_INAME + I '$D(@STORE@("T",INS,TNAME,TIEN)) S @STORE@("T",INS,TNAME,TIEN)="",@STORE@(INS,TIEN)="Team: "_TNAME + I '$D(@STORE@("C",INS,TIEN,CNAME,CIEN)) S @STORE@("C",INS,TIEN,CNAME,CIEN)="" ;D HEADER(INS,TIEN,CIEN) + I '$D(@STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)) S @STORE@("PT",INS,TIEN,CIEN,PNAME,PTIEN)="" + Q + ; +PCASSIGN(DFN,TIEN) ;patient assigned to team as primary care + ;DFN - patient ien + ;TIEN - team ien + ;1 - yes + ;0 - no + ; + N ADATE,ENTRY,PC + S PC=0 + I '$D(^SCPT(404.42,"AIDT",DFN,TIEN)) Q PC + S ADATE=$O(^SCPT(404.42,"AIDT",DFN,TIEN,"")) ; -team assignemtn date + S ENTRY=$O(^SCPT(404.42,"AIDT",DFN,TIEN,ADATE,"")) ;patient team assignemtn ien + I $P($G(^SCPT(404.42,+ENTRY,0)),"^",8)=1 S PC=1 + Q PC + ; +HEADER ;report column titles + N HLD + S HLD="H0" + S $E(@STORE@("SUBHEADER",HLD),25)="M.T." + S $E(@STORE@("SUBHEADER",HLD),31)="Prim" + ;Removed by patch 174 + ;S $E(@STORE@("SUBHEADER",HLD),31)="Pat" + ;S $E(@STORE@("SUBHEADER",HLD),36)="Status" + S $E(@STORE@("SUBHEADER",HLD),42)="Last" + S $E(@STORE@("SUBHEADER",HLD),54)="Next" + S $E(@STORE@("SUBHEADER",HLD),66)="Enrolled" + S $E(@STORE@("SUBHEADER",HLD),95)="Primary Care" + S $E(@STORE@("SUBHEADER",HLD),115)="Associate" + S HLD="H1" + S @STORE@("SUBHEADER",HLD)="Patient Name" + S $E(@STORE@("SUBHEADER",HLD),18)="Pt ID" + S $E(@STORE@("SUBHEADER",HLD),25)="Stat" + S $E(@STORE@("SUBHEADER",HLD),31)="Elig" + ;Removed by patch 174 + ;S $E(@STORE@("SUBHEADER",HLD),31)="Stat" + ;S $E(@STORE@("SUBHEADER",HLD),36)="Date" + S $E(@STORE@("SUBHEADER",HLD),42)="Appt" + S $E(@STORE@("SUBHEADER",HLD),54)="Appt" + S $E(@STORE@("SUBHEADER",HLD),66)="Clinic" + S $E(@STORE@("SUBHEADER",HLD),95)="Provider" + S $E(@STORE@("SUBHEADER",HLD),115)="Provider" + S HLD="H2" + S $P(@STORE@("SUBHEADER",HLD),"=",133)="" + Q + ; +FORMAT(PTIEN,INS,TIEN,PDATA,CNAME,CIEN) ;format data for report + ;PTIEN - patient ien + ;INS - institution ien + ;TIEN - team ien + ;PDATA - pt name^pid^mt^pelig^pstat^statd^last^next^pc prov.^assoc. prov. + ;CNAME - clinic name + ;CIEN - clinic ien + ; + S @STORE@(INS,TIEN,CIEN,PTIEN)=$E($P(PDATA,"^"),1,15) ;patient name + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),18)=$E($P(PDATA,"^",2),6,10) ;primary long id last 4 plus P + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),25)=$P(PDATA,"^",3) ;means test category + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",4) ;primary eligibility + ;Removed by patch 174 + ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),31)=$P(PDATA,"^",5) ;patient status + ;S $E(@STORE@(INS,TIEN,CIEN,PTIEN),35)=$P(PDATA,"^",6) ;status date + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),42)=$P(PDATA,"^",7) ;last appointment + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),54)=$P(PDATA,"^",8) ;next appointment + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),66)=$E(CNAME,1,27) ;clinic name + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),95)=$E($P(PDATA,U,9),1,18) ;PC prov. + S $E(@STORE@(INS,TIEN,CIEN,PTIEN),115)=$E($P(PDATA,U,10),1,18) ;Assoc. Prov. + Q + ; +CHEAD(INS,TEAM,CLINIC) ; + ;column headings + ; + N EN,NEWP + W ! + S NEWP=0 + I IOST'?1"C-".E,$Y+5>(IOSL-6) D NEWP1^SCRPU3(.PAGE,TITL) S NEWP=1 + I IOST?1"C-".E,$Y+5>(IOSL-6) D HOLD^SCRPU3(.PAGE,TITL) S NEWP=1 + I STOP Q + I NEWP W !,$G(@STORE@(INS)),!!,$G(@STORE@(INS,TEAM)),! +CH2 F EN="H0","H1","H2" W !,$G(@STORE@("SUBHEADER",EN)) + Q + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP.m (revision 623) @@ -1,149 +1,144 @@ -SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,52,177,520**;AUG 13, 1993;Build 26 - ; - ;Individual Team Profile - ; -PROMPTS ; - ;Prompt for Institution, Team, and Print device - ; - N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER - K VAUTD,VAUTT,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT) Q - ; -QUE(INST,TEAM) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - N ZTSAVE,II - F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPITP" - S ZTDESC="iIndividual Team Profile",ZTIO=IOP - N II - F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Individual Team Profile" - S STORE="^TMP("_$J_",""SCRPITP"")" - K @STORE - S @STORE=0 - I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE - Q - ; -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,NODATA - Q - ; -FIND ; - N TM,EN,NODE,TMP,TPNAME - S TM="" K ^TMP("SCRATCH",$J) - F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D - .;$O through team position file - .I '$D(TEAM(TM))&(TEAM'=1) Q - .;Q above, not a selected team - .;selected team - .S EN="" - .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D - ..I '$D(^SCTM(404.57,EN,0)) Q - ..S NODE=$G(^SCTM(404.57,EN,0)) - ..Q:NODE="" - ..;active or inactive position - ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT) - ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~" - ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE - ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE - ..Q - .Q - S TM="" - F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D - .F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D - ..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D - ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN) - ...D KEEP^SCRPITP2(NODE,EN,TM) - ...Q - ..Q - .Q - Q - ; -PRINTIT(STORE,TITL) ; - N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF,ACL - S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF - D FORHEAD^SCRPITP2 - F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D - .S INST=$O(@STORE@("I",EINST,"")) - .I INST="" Q - .I STOP Q - .;write team info - .S TNAME="" - .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D - ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132) - ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132) - ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132) - ..W !,$G(@STORE@(INST)),! S NEW="" - ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) - ..I TIEN="" Q - ..F SUB="TI","D" D - ...Q:STOP - ...I '$D(@STORE@(INST,TIEN,SUB)) Q - ...S EN="" - ...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D - ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) - ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) - ....I STOP Q - ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),! - ....W !,$G(@STORE@(INST,TIEN,SUB,EN)) - ...W ! - ..;write position info - ..S POS="" - ..I $Y(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 - ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 - ....I STOP Q - ...;W !,$G(@STORE@(INST,TIEN,"P",POS)) - ...;W !,$G(@STORE@(INST,TIEN,"P",POS,ACL)) - ...W ! - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q +SCRPITP ;ALB/CMM - Individual Team Profile ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,52,177**;AUG 13, 1993 + ; + ;Individual Team Profile + ; +PROMPTS ; + ;Prompt for Institution, Team, and Print device + ; + N QTIME,PRNT,VAUTD,VAUTT,Y,NUMBER + K VAUTD,VAUTT,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT) Q + ; +QUE(INST,TEAM) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + N ZTSAVE,II + F II="INST","TEAM","INST(","TEAM(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPITP","Individual Team Profile",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPITP" + S ZTDESC="iIndividual Team Profile",ZTIO=IOP + N II + F II="INST","TEAM","INST(","TEAM(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Individual Team Profile" + S STORE="^TMP("_$J_",""SCRPITP"")" + K @STORE + S @STORE=0 + I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE + Q + ; +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,NODATA + Q + ; +FIND ; + N TM,EN,NODE,TMP,TPNAME + S TM="" K ^TMP("SCRATCH",$J) + F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D + .;$O through team position file + .I '$D(TEAM(TM))&(TEAM'=1) Q + .;Q above, not a selected team + .;selected team + .S EN="" + .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D + ..I '$D(^SCTM(404.57,EN,0)) Q + ..S NODE=$G(^SCTM(404.57,EN,0)) + ..Q:NODE="" + ..;active or inactive position + ..S TMP=$$DATES^SCAPMCU1(404.59,EN,DT) + ..S TPNAME=$P(NODE,U) S:'$L(TPNAME) TPNAME="~~~" + ..S ^TMP("SCRATCH",$J,TPNAME,EN)=NODE + ..I +TMP S ^TMP("SCRATCH",$J,TM,TPNAME,EN)=NODE + ..Q + .Q + S TM="" + F S TM=$O(^TMP("SCRATCH",$J,TM)) Q:TM="" S TPNAME="" D + .F S TPNAME=$O(^TMP("SCRATCH",$J,TM,TPNAME)) Q:TPNAME="" S EN="" D + ..F S EN=$O(^TMP("SCRATCH",$J,TM,TPNAME,EN)) Q:EN="" D + ...S NODE=^TMP("SCRATCH",$J,TM,TPNAME,EN) + ...D KEEP^SCRPITP2(NODE,EN,TM) + ...Q + ..Q + .Q + Q + ; +PRINTIT(STORE,TITL) ; + N INST,EINST,ETEAM,TEM,NEW,PAGE,TNAME,TIEN,EN,SUB,POS,CIEN,INF + S (INST,EINST)="",STOP=0,(PAGE,NEW)=1 W:$E(IOST)="C" @IOF + D FORHEAD^SCRPITP2 + F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D + .S INST=$O(@STORE@("I",EINST,"")) + .I INST="" Q + .I STOP Q + .;write team info + .S TNAME="" + .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D + ..D:NEW TITLE^SCRPU3(.PAGE,TITL,132) + ..I 'NEW,$E(IOST)'="C" D NEWP1^SCRPU3(.PAGE,TITL,132) + ..I 'NEW,$E(IOST)="C" D HOLD^SCRPU3(.PAGE,TITL,132) + ..W !,$G(@STORE@(INST)),! S NEW="" + ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) + ..I TIEN="" Q + ..F SUB="TI","D" D + ...Q:STOP + ...I '$D(@STORE@(INST,TIEN,SUB)) Q + ...S EN="" + ...F S EN=$O(@STORE@(INST,TIEN,SUB,EN)) Q:EN=""!(STOP) D + ....I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) + ....I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) + ....I STOP Q + ....I '$D(NEW) W !,$G(@STORE@(INST)),!,$G(@STORE@(INST,TIEN)),! + ....W !,$G(@STORE@(INST,TIEN,SUB,EN)) + ...W ! + ..;write position info + ..S POS="" + ..I $Y(IOSL-5) D NEWP1^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 + ...I IOST?1"C-".E,$Y>(IOSL-5) D HOLD^SCRPU3(.PAGE,TITL,132) Q:STOP D CONT^SCRPITP2 + ...I STOP Q + ...W !,$G(@STORE@(INST,TIEN,"P",POS)) + ..W ! + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPITP2.m (revision 623) @@ -1,132 +1,121 @@ -SCRPITP2 ;ALB/CMM - Individual Team Profile Continued ;7/25/99 18:24 - ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26 - ; - ;Individual Team Profile - ; -KEEP(TNODE,TPOS,TM,SCEN) ; - ;TNODE - zero node of the team position file entry TPOS - ;TPOS - ien of team position file entry TNODE - ;TM - ien of team - ; - N POS,PPC,CLIEN,PCLIN,MAX,ROL,CIEN,DIV - N SCRDATE,SCI,PROVLIST,SCPROV,SCPTASS,ERR - ; - D TEAM(TM,.DIV) - ; - S POS=$P(TNODE,"^") ;position name - S ROL=$P($G(^SD(403.46,+$P(TNODE,"^",3),0)),"^") ;standard position - S PPC=$S($P(TNODE,"^",4)'=1:"NPC",+$$OKPREC3^SCMCLK(TPOS,DT)>0:" AP",1:"PCP") ;primary care position - S MAX=$P(TNODE,"^",8) - ; - S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0 - S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0) - S SCPROV=$P($G(PROVLIST(1)),U,2) - S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0) - ; - ;D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,SCPROV,SCPTASS) - ; - D SETASCL^SCRPRAC2(TPOS,.CNAME,.CLIEN) - S CNAME=$G(CNAME(0)) - ;S CIEN=+$P(TNODE,"^",9) ;clinic ien ;USING MULTIPLE WITH SD*5.3*520 - ;S PCLIN="" - ;I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic - ; - D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,CNAME,SCPROV,SCPTASS) - N AC - S AC=0 - F S AC=$O(CNAME(AC)) Q:AC="" D FORMATAC(POS,DIV,TM,TPOS,CNAME(AC)) - K CNAME - Q - ; -TEAM(TM,DIV) ; - ; - N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR - S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file - S TNAME=$P(TMN,"^") ;team name - S DIV=+$P(TMN,"^",7) ;division ien - S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division - S TPHONE=$P(TMN,"^",2) ;team phone - S TPC=+$P(TMN,"^",5) ;Primary Care Team ien - S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section - S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status - S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^") - S MAX=$P(TMN,"^",8) - S CUR=$$TEAMCNT^SCAPMCU1(TM,DT) - D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) - ; - ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD) - D TDESC(TM,DIV) - Q -TDESC(TEM,DIV) ; - ;gets team description - word processing field - Q:'$O(^SCTM(404.51,TEM,"D",0)) - N EN - S EN=0 - S @STORE@(DIV,TEM,"D",0)="Team Description: " - S @STORE@(DIV,TEM,"D",.5)="" - F S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN="" D - .S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0)) - Q - ; -TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ; - ; - I TNAME="" S TNAME="[BAD DATA]" - I TDIV="" S TDIV="[BAD DATA]" - S @STORE@("I",TDIV,DIV)="" - S @STORE@("T",DIV,TNAME,TM)="" - S @STORE@(DIV)="Division: "_TDIV - ; - S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME - S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30) - S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE - S @STORE@(DIV,TM,"TI",2)="" - S @STORE@(DIV,TM,"TI",3)="Team Settings:" - S @STORE@(DIV,TM,"TI",4)="" - S @STORE@(DIV,TM,"TI",5)="Status: "_STAT - S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX - S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR - S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35) - S @STORE@(DIV,TM,"TI",6)="" - I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients." - I CUR1:" AP",1:"PCP") ;primary care position + S MAX=$P(TNODE,"^",8) + ; + S SCRDATE="SCRDATE",(SCRDATE("BEGIN"),SCRDATE("END"))=DT,SCRDATE("INCL")=0 + S SCI="PROVLIST",SCI=$$PRTP^SCAPMC(TPOS,.SCRDATE,SCI,"ERR",1,0) + S SCPROV=$P($G(PROVLIST(1)),U,2) + S SCPTASS=$$PCPOSCNT^SCAPMCU1(TPOS,DT,0) + ; + S CIEN=+$P(TNODE,"^",9) ;clinic ien + S PCLIN="" + I CIEN>0 S PCLIN=$P($G(^SC(CIEN,0)),"^") ;associated clinic + ; + D FORMAT(POS,PPC,MAX,DIV,TM,TPOS,ROL,PCLIN,SCPROV,SCPTASS) + ; + Q + ; +TEAM(TM,DIV) ; + ; + N TMN,TNAME,TDIV,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR + S TMN=$G(^SCTM(404.51,TM,0)) ;zero node of team file + S TNAME=$P(TMN,"^") ;team name + S DIV=+$P(TMN,"^",7) ;division ien + S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division + S TPHONE=$P(TMN,"^",2) ;team phone + S TPC=+$P(TMN,"^",5) ;Primary Care Team ien + S TSERV=$P($G(^DIC(49,+$P(TMN,"^",6),0)),"^") ;Service/section + S STAT=$S(+$$ACTTM^SCMCTMU(TM)=1:"ACTIVE",1:"INACTIVE") ;Team status + S PUR=$P($G(^SD(403.47,+$P(TMN,"^",3),0)),"^") + S MAX=$P(TMN,"^",8) + S CUR=$$TEAMCNT^SCAPMCU1(TM,DT) + D TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) + ; + ;GET TEAM DESCRIPTION (WORD PROCESSING FIELD) + D TDESC(TM,DIV) + Q +TDESC(TEM,DIV) ; + ;gets team description - word processing field + Q:'$O(^SCTM(404.51,TEM,"D",0)) + N EN + S EN=0 + S @STORE@(DIV,TEM,"D",0)="Team Description: " + S @STORE@(DIV,TEM,"D",.5)="" + F S EN=$O(^SCTM(404.51,TEM,"D",EN)) Q:EN="" D + .S @STORE@(DIV,TEM,"D",EN)=$G(^SCTM(404.51,TEM,"D",EN,0)) + Q + ; +TFORMAT(TNAME,DIV,TDIV,TM,TPHONE,TPC,TSERV,STAT,PUR,MAX,CUR) ; + ; + I TNAME="" S TNAME="[BAD DATA]" + I TDIV="" S TDIV="[BAD DATA]" + S @STORE@("I",TDIV,DIV)="" + S @STORE@("T",DIV,TNAME,TM)="" + S @STORE@(DIV)="Division: "_TDIV + ; + S @STORE@(DIV,TM,"TI",1)="Team Name: "_TNAME + S $E(@STORE@(DIV,TM,"TI",1),44)="Service/Section: "_$E(TSERV,1,30) + S $E(@STORE@(DIV,TM,"TI",1),(120-$L(TPHONE)))="Team Phone: "_TPHONE + S @STORE@(DIV,TM,"TI",2)="" + S @STORE@(DIV,TM,"TI",3)="Team Settings:" + S @STORE@(DIV,TM,"TI",4)="" + S @STORE@(DIV,TM,"TI",5)="Status: "_STAT + S $E(@STORE@(DIV,TM,"TI",5),19)="Maximum Patients: "_MAX + S $E(@STORE@(DIV,TM,"TI",5),47)="Unique Patients Assigned: "_CUR + S $E(@STORE@(DIV,TM,"TI",5),83)="Purpose: "_$E(PUR,1,35) + S @STORE@(DIV,TM,"TI",6)="" + I CUR+1>MAX S @STORE@(DIV,TM,"TI",7)="This team is not accepting patients." + I CURDT S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name - Q - ; -FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display - ;CNAME - clinic name - ;PINF - patient/clinic data - ;PC - primary care 1/0 - ;TIEN - team file ien (#404.51) - ;TNAME - team name - ;PRAC - practitioner ien (#200) - ;PNAME - practitioner name - ;POSN - position name - ;TPI - team position ien (#404.57) - ;PRCP - preceptor name - ; - N IIEN,INAME,ERR - S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) - I ERR Q - ; - I SORT=1 D STOR(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI) ;sort division,team,practitioner - I SORT=2 D STOR(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI) ;sort division,practitioner,team - I SORT=3 D STOR(1,PRAC,1,PINF,PNAME,"T3",TPI) - Q - ; -FORMATAC(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display - ;CNAME - clinic name - ;PINF - patient/clinic data - ;PC - primary care 1/0 - ;TIEN - team file ien (#404.51) - ;TNAME - team name - ;PRAC - practitioner ien (#200) - ;PNAME - practitioner name - ;POSN - position name - ;TPI - team position ien (#404.57) - ;PRCP - preceptor name - ; - N IIEN,INAME,ERR - S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) - I ERR Q - ; - I SORT=1 D STORA(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,team,practitioner - I SORT=2 D STORA(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI,SCCNT) ;sort division,practitioner,team - I SORT=3 D STORA(1,PRAC,1,PINF,PNAME,"T3",TPI,SCCNT) - Q - ; -STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ; - ;IIEN - ien institution - ;SEC - second sort subscript, IEN team or IEN practitioner - ;TRD - third sort subscript, IEN team or IEN practitioner - ;PINF - patient/clinic info - ;PNAME - practitioner name - ;TNAME - team name - ;TPI - team position ien - ; - N PIEN,PTNAME,PID - S PIEN=+$P(PINF,"^") ;patient ien - S PTNAME=$E($P(PINF,"^",2),1,10) ;patient name - Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)) - S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)="" - I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D - .;count each unique patient for any given practitioner for grand total - .S @STORE@("PTOT",IIEN,SEC,TRD,PIEN)="" - .S @STORE@("TOTAL",IIEN,PRAC,0)=$G(@STORE@("TOTAL",IIEN,PRAC,0))+1 ;patient count by practitioner - ; - S @STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI)=$G(@STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI))+1 ;patient count by practitioner and team - Q:SUMM - ; - S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME - S PID=$P(PINF,"^",3),PID=$TR(PID,"-","") - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),13)=PID ;ssn - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility - ;Removed by patch 174 - ;S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),40)=$P(PINF,"^",6) ;patient status - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),42)=$P(PINF,"^",8) ;last appt - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),54)=$P(PINF,"^",9) ;nxt appt - S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic - Q -STORA(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI,SCCNT) ; - I '$D(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT)) D - .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),42)=$P(PINF,"^",8) ;last appt - .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),54)=$P(PINF,"^",9) ;nxt appt - .S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN,SCCNT),66)=$E(CNAME,1,15) ;clinic - .Q - Q +SCRPPAT2 ;ALB/CMM - Practitioner's Patients ; 12/12/00 3:46pm + ;;5.3;Scheduling;**41,48,174,181,177,231,433,297**;AUG 13, 1993 + ; + ;Listing of Practitioner's Patients + ; +DRIVE ; + ;driver module + N PRAC,INF,ARRY,ERROR,NXT,OKAY,PIEN,TPRC + S ARRY="^TMP(""SCARRAY"","_$J_")",ERROR="ERR" + S TPRC="^TMP(""SCRP"",$J,""PRACT"")" M @TPRC=PRACT + K @ARRY,@ERROR,PRACT + I @TPRC=1 D ALL^SCRPPAT3 ;all practitioners selected + S NXT=0 + F S NXT=$O(@TPRC@(NXT)) Q:NXT=""!(NXT'?.N) D + .I @TPRC=0 S PIEN=NXT + .I @TPRC=1 S PIEN=$P(@TPRC@(NXT),"^") + .K @ARRY,@ERROR + .S OKAY=$$PTPR^SCAPMC14(PIEN,"","","",ARRY,ERROR) ;patients for practitioner + .I '+OKAY Q + .D LOOPPT(ARRY,PIEN) ;loop through patients for practitioner + K @ARRY,@ERROR,@TPRC + K:SUMM @STORE@("PT") + Q + ; +LOOPPT(ARY,PRAC) ;loop through patients for practitioner + ;ARY - array of patients for selected practitioner + ;PRAC - practitioner ien + N NXT,PIEN,TPIEN,PNAME,TPIEN,NODE,PTP,TPI,TPN,CLIEN,CNAME,PTA,PTAN,TIEN + N PC,TNODE,TNAME,PINF,POSN,PRCP + S NXT=0 + F S NXT=$O(@ARY@(NXT)) Q:NXT=""!(NXT'?.N) D + .S NODE=$G(@ARY@(NXT)) + .Q:NODE="" + .S PIEN=+$P(NODE,"^") ;ien of patient file entry + .S TPIEN=+$P(NODE,"^",3) ;ien of patient team position assignment + .S PTP=$G(^SCPT(404.43,TPIEN,0)) + .Q:PTP="" + .S PTA=+$P(PTP,"^") ;patient team assignment ien (404.42) + .S PTAN=$G(^SCPT(404.42,PTA,0)) + .Q:PTAN="" + .S TIEN=+$P(PTAN,"^",3) ;team file ien (404.51) + .I $G(TEAM)'=1,'$D(TEAM(TIEN)) Q ;not a selected team + .S TNODE=$G(^SCTM(404.51,TIEN,0)) + .Q:TNODE="" I $G(INST)'=1,'$D(INST(+$P(TNODE,U,7))) Q + .S TNAME=$P(TNODE,"^") ;team name + .S TPI=+$P(PTP,"^",2) ;Team Position file ien (404.57) + .S TPN=$G(^SCTM(404.57,TPI,0)) + .Q:TPN="" + .I $G(ROLE)'=1,'$D(ROLE(+$P(TPN,U,3))) Q ;not a selected role + .S POSN=$P(TPN,"^") ;position name + .S CLIEN=+$P(TPN,"^",9) ;associated clinic ien + .;commented next line off - clinic enrollment no longer needed SD*5.3*433 + .;D CECHK(CLIEN,.CNAME,PIEN) ;is patient enrolled in associated clinic? + .S CNAME=$P($G(^SC(CLIEN,0)),"^") ; SD*5.3*433 remove enroll check + .S PC=$S($P(PTP,"^",5)=0:0,1:1) ;primary care position 1or2-yes/0-no + .S PNAME=$P($G(^VA(200,+PRAC,0)),"^") ;practitioner name + .Q:PNAME="" + .S PRCP=$P($$OKPREC2^SCMCLK(TPI,DT),U,2) + .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CLIEN,1) + .;$$PDATA returns pt name,pid,mt,pelig,status,status date,last appt,nxt appt + .D FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ;formats data for display + Q + ; +CECHK(CLIEN,CNAME,PIEN) ; + ;CLIEN - clinic ien + ;CNAME - clinic name returned if patient is enrolled in clien clinic + ;PIEN - patien ien + ; + N EN,NODE + S CNAME="" + I $D(^DPT(PIEN,"DE","B",CLIEN)) D + .;enrolled at one time, check if discharged + .S EN=$O(^DPT(PIEN,"DE","B",CLIEN,"")) + .S NODE=$G(^DPT(PIEN,"DE",EN,0)) + .Q:NODE="" + .I $P(NODE,"^",3)="" S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name + .I $P(NODE,"^",3)'="",$P(NODE,"^",3)>DT S CNAME=$P($G(^SC(CLIEN,0)),"^") ;clinic name + Q + ; +FORMAT(CNAME,PINF,PC,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; format data for display + ;CNAME - clinic name + ;PINF - patient/clinic data + ;PC - primary care 1/0 + ;TIEN - team file ien (#404.51) + ;TNAME - team name + ;PRAC - practitioner ien (#200) + ;PNAME - practitioner name + ;POSN - position name + ;TPI - team position ien (#404.57) + ;PRCP - preceptor name + ; + N IIEN,INAME,ERR + S ERR=$$SETUP^SCRPPAT3(.IIEN,.INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) + I ERR Q + ; + I SORT=1 D STOR(IIEN,TIEN,PRAC,PINF,PNAME,TNAME,TPI) ;sort division,team,practitioner + I SORT=2 D STOR(IIEN,PRAC,TIEN,PINF,PNAME,TNAME,TPI) ;sort division,practitioner,team + I SORT=3 D STOR(1,PRAC,1,PINF,PNAME,"T3",TPI) + Q + ; +STOR(IIEN,SEC,TRD,PINF,PNAME,TNAME,TPI) ; + ;IIEN - ien institution + ;SEC - second sort subscript, IEN team or IEN practitioner + ;TRD - third sort subscript, IEN team or IEN practitioner + ;PINF - patient/clinic info + ;PNAME - practitioner name + ;TNAME - team name + ;TPI - team position ien + ; + N PIEN,PTNAME,PID + S PIEN=+$P(PINF,"^") ;patient ien + S PTNAME=$E($P(PINF,"^",2),1,15) ;patient name + Q:$D(@STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)) + S @STORE@("PT",IIEN,SEC,TRD,TPI,PTNAME,PIEN)="" + ; + I 'SUMM,'$D(@STORE@("PTOT",IIEN,SEC,TRD,PIEN)) D + .;count each unique patient for any given practitioner for grand total + .S @STORE@("PTOT",IIEN,SEC,TRD,PIEN)="" + .S @STORE@("TOTAL",IIEN,PRAC,0)=$G(@STORE@("TOTAL",IIEN,PRAC,0))+1 ;patient count by practitioner + ; + S @STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI)=$G(@STORE@("TOTAL",IIEN,PRAC,$S(SORT=3:1,1:TIEN),TPI))+1 ;patient count by practitioner and team + Q:SUMM + ; + S @STORE@(IIEN,SEC,TRD,TPI,PIEN)=PTNAME + S PID=$P(PINF,"^",3),PID=$TR(PID,"-","") + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),18)=$E(PID,6,10) ;last 4 pid - 5 places is for any pseudo + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),25)=$P(PINF,"^",4) ;means test status + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),31)=$P(PINF,"^",5) ;eligibility + ;Removed by patch 174 + ;S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),40)=$P(PINF,"^",6) ;patient status + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),42)=$P(PINF,"^",8) ;last appt + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),54)=$P(PINF,"^",9) ;nxt appt + S $E(@STORE@(IIEN,SEC,TRD,TPI,PIEN),66)=$E(CNAME,1,15) ;clinic + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPPAT3.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPPAT3.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPPAT3.m (revision 623) @@ -1,146 +1,139 @@ -SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm - ;;5.3;Scheduling;**41,52,148,174,181,177,297,526,520**;AUG 13, 1993;Build 26 - ; - ;Listing of Practitioner's Patients - ; -PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; - ;writes patients for position/practitioner - N PTN,PT,FIRST - S PTN="",FIRST=1 - I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q ;Summary only - F S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP) D - .S PT=0 - .F S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP) D - ..I FIRST D HEADER S FIRST=0 - ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line - ..;I FIRST D HEADER S FIRST=0 - ..N SCCN - ..S SCCN="" - ..F S SCCN=$O(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) Q:SCCN="" D - ...W !,$G(@STORE@(INS,SEC,TRD,POS,PT,SCCN)) ;print patient detail line - ...I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER - ...I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER - ...Q:STOP - ...;I FIRST D HEADER S FIRST=0 - ...Q - ..Q - .Q - Q - ; -SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only - ;STORE - global location of data - ;IOP - device to print to - ;TITL - title of report - ;SORT - sort order 1-div,team,pract/2-div,pract,team - ; - N PAGE - S PAGE=1,STOP=0 - D OPEN^SCRPU3 - Q:$G(POP) - D TITLE^SCRPU3(.PAGE,TITL) - D CLOSE^SCRPU3 - Q - ; -TOTAL1(INS,SEC,TRD,POS) ; - ;print team/practitioner total - N TEM,PRC - I SORT=1 S TEM=SEC,PRC=TRD - I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC - W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS)) - Q - ; -HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; - I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D - .W !,$G(@ST3@(INS,SEC)) ;write team (sort 1) - .W !,$G(@STORE@(INS)) - .W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2) - .I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP") - .W ! - I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D - .W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1) - .I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP") - .I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2) - .W !,$G(@STORE@(INS)) - Q - ; -HEADER ; - Q:$G(MORE) - I SORT=3 S MORE=1 - N NXT - F NXT="H1","H2","H3" W !,$G(@STORE@(NXT)) - W ! - Q - ; -SHEAD ; - S @STORE@("H2")="Pt Name" - S $E(@STORE@("H2"),15)="Pt ID" - S $E(@STORE@("H1"),25)="M.T." - S $E(@STORE@("H2"),25)="Stat" - S $E(@STORE@("H1"),31)="Prim" - S $E(@STORE@("H2"),31)="Elig" - ;Removed by patch 174 - ;S $E(@STORE@("H1"),39)="Pat" - ;S $E(@STORE@("H2"),39)="Stat" - S $E(@STORE@("H1"),42)="Last" - S $E(@STORE@("H2"),42)="Appt" - S $E(@STORE@("H1"),54)="Next" - S $E(@STORE@("H2"),54)="Appt" - S $E(@STORE@("H2"),66)="Clinic" - S $P(@STORE@("H3"),"=",81)="" - Q -ALL ; - ;get all practitioners for all teams selected - I TEAM=1 D TALL ;all teams selected - N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT - S TIEN="" - F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D - .I $D(TEAM(TIEN)) D - ..K XLIST - ..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR") - ..S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D - ...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0 - ...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) - ...S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D - ....S @TPRC@(0)=$G(@TPRC@(0))+1 - ....S @TPRC@(@TPRC@(0))=YLIST(SCI) - Q - ; -TALL ; - ;get all active team for divisions selected - N NXT,IIEN,NODE - S NXT=0,IIEN="" - ;$O through team file and find all active teams for selected divisions - F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D - .I INST=1!$D(INST(IIEN)) D - ..S TIEN=0 - ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D - ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" - Q - ; -SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; - ;setup data - S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien - S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name - I INAME="" S INAME="[BAD DATA]" - ; - I PNAME="" S PNAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - I $G(SORT)=3 S IIEN=1,TIEN=1 - I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")") - I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")=" Preceptor: "_PRCP - I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))=" Team: "_TNAME - ; - I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:" Division: "_INAME) - S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))="" - I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)="" - I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0 - I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0 - ; - S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": " - S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": " - N SCX - S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22) - S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX - ; - S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner" - Q 0 +SCRPPAT3 ;ALB/CMM - Practitioner's Patients ; 8/30/99 3:14pm + ;;5.3;Scheduling;**41,52,148,174,181,177,297**;AUG 13, 1993 + ; + ;Listing of Practitioner's Patients + ; +PAT(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; + ;writes patients for position/practitioner + N PTN,PT,FIRST + S PTN="",FIRST=1 + I SUMM D TOTAL1^SCRPPAT3(INS,SEC,TRD,POS) Q ;Summary only + F S PTN=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN)) Q:PTN=""!(STOP) D + .S PT=0 + .F S PT=$O(@STORE@("PT",INS,SEC,TRD,POS,PTN,PT)) Q:'PT!(STOP) D + ..I (IOST'?1"C-".E),$Y>(IOSL-5) S MORE=0 D NEWP1^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:(('FIRST&'STOP)!($G(SORT)=3)) HEADER + ..I (IOST?1"C-".E),$Y>(IOSL-5) S MORE=0 D HOLD^SCRPU3(.PAGE,TITL) D:'STOP HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) D:'FIRST&'STOP HEADER + ..Q:STOP + ..I FIRST D HEADER S FIRST=0 + ..W !,$G(@STORE@(INS,SEC,TRD,POS,PT)) ;print patient detail line + ..Q + .Q + Q + ; +SPRINT(STORE,IOP,TITL,SORT) ; Summary Print Only + ;STORE - global location of data + ;IOP - device to print to + ;TITL - title of report + ;SORT - sort order 1-div,team,pract/2-div,pract,team + ; + N PAGE + S PAGE=1,STOP=0 + D OPEN^SCRPU3 + Q:$G(POP) + D TITLE^SCRPU3(.PAGE,TITL) + D CLOSE^SCRPU3 + Q + ; +TOTAL1(INS,SEC,TRD,POS) ; + ;print team/practitioner total + N TEM,PRC + I SORT=1 S TEM=SEC,PRC=TRD + I SORT=2!(SORT=3) S TEM=TRD,PRC=SEC + W !!,$G(@STORE@("TH",INS,PRC,TEM,POS)),$G(@STORE@("TOTAL",INS,PRC,TEM,POS)) + Q + ; +HEAD2(INS,SEC,TRD,SEC3,ST3,ST4,POS) ; + I (SEC3="""TN""")&($D(@ST4@(INS,TRD,SEC))) D + .W !,$G(@ST3@(INS,SEC)) ;write team (sort 1) + .W !,$G(@STORE@(INS)) + .W !,$G(@ST4@(INS,TRD,SEC,POS)) ;write practitioner (sort 2) + .I $L($G(@STORE@("PN",INS,TRD,SEC,POS,"PRCP"))) W !,@STORE@("PN",INS,TRD,SEC,POS,"PRCP") + .W ! + I (SEC3="""PN""")&($D(@ST3@(INS,SEC,TRD))) D + .W !,$G(@ST3@(INS,SEC,TRD,POS)) ;write practitioner (sort 1) + .I $G(SORT)'=3 I $L($G(@STORE@("PN",INS,SEC,TRD,POS,"PRCP"))) W !,@STORE@("PN",INS,SEC,TRD,POS,"PRCP") + .I $G(SORT)'=3 W !,$G(@ST4@(INS,TRD)) ;write team (sort 2) + .W !,$G(@STORE@(INS)) + Q + ; +HEADER ; + Q:$G(MORE) + I SORT=3 S MORE=1 + N NXT + F NXT="H1","H2","H3" W !,$G(@STORE@(NXT)) + W ! + Q + ; +SHEAD ; + S @STORE@("H2")="Pt Name" + S $E(@STORE@("H2"),18)="Pt ID" + S $E(@STORE@("H1"),25)="M.T." + S $E(@STORE@("H2"),25)="Stat" + S $E(@STORE@("H1"),31)="Prim" + S $E(@STORE@("H2"),31)="Elig" + ;Removed by patch 174 + ;S $E(@STORE@("H1"),39)="Pat" + ;S $E(@STORE@("H2"),39)="Stat" + S $E(@STORE@("H1"),42)="Last" + S $E(@STORE@("H2"),42)="Appt" + S $E(@STORE@("H1"),54)="Next" + S $E(@STORE@("H2"),54)="Appt" + S $E(@STORE@("H2"),66)="Clinic" + S $P(@STORE@("H3"),"=",81)="" + Q +ALL ; + ;get all practitioners for all teams selected + I TEAM=1 D TALL ;all teams selected + N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT + S TIEN="" + F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D + .I $D(TEAM(TIEN)) D + ..K XLIST + ..S OKAY=$$TPTM^SCAPMC(TIEN,"","","","XLIST","ERROR") + ..S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D + ...K YLIST S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0 + ...S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) + ...S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D + ....S @TPRC@(0)=$G(@TPRC@(0))+1 + ....S @TPRC@(@TPRC@(0))=YLIST(SCI) + Q + ; +TALL ; + ;get all active team for divisions selected + N NXT,IIEN,NODE + S NXT=0,IIEN="" + ;$O through team file and find all active teams for selected divisions + F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D + .I INST=1!$D(INST(IIEN)) D + ..S TIEN=0 + ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D + ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" + Q + ; +SETUP(IIEN,INAME,TIEN,TNAME,PRAC,PNAME,POSN,TPI,PRCP) ; + ;setup data + S IIEN=+$P($G(^SCTM(404.51,TIEN,0)),"^",7) ;institution ien + S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name + I INAME="" S INAME="[BAD DATA]" + ; + I PNAME="" S PNAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + I $G(SORT)=3 S IIEN=1,TIEN=1 + I '$D(@STORE@("PN",IIEN,PRAC,TIEN,TPI)) S @STORE@("PN",IIEN,PRAC,TIEN,TPI)="Practitioner: "_PNAME_$S(SORT=3:"",1:" ("_POSN_")") + I $L(PRCP) S @STORE@("PN",IIEN,PRAC,TIEN,TPI,"PRCP")=" Preceptor: "_PRCP + I '$D(@STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))) S @STORE@("TN",IIEN,$S($G(SORT)=3:1,1:TIEN))=" Team: "_TNAME + ; + I '$D(@STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)) S @STORE@("I",$S($G(SORT)=3:"S3",1:INAME),IIEN)="",@STORE@(IIEN)=$S(SORT=3:"",1:" Division: "_INAME) + S @STORE@("T",IIEN,$S($G(SORT)=3:"T3",1:TNAME),$S($G(SORT)=3:1,1:TIEN))="" + I '$D(@STORE@("P",IIEN,PNAME,PRAC,TPI)) S @STORE@("P",IIEN,PNAME,PRAC,TPI)="" + I '$D(@STORE@("TOTAL",IIEN,PRAC,0)) S @STORE@("TOTAL",IIEN,PRAC,0)=0 + I '$D(@STORE@("TOTAL",IIEN,PRAC,TIEN)) S @STORE@("TOTAL",IIEN,PRAC,TIEN)=0 + ; + S @STORE@("TH",IIEN,PRAC)="Patient Count for "_PNAME_": " + S @STORE@("TH",IIEN,PRAC,TIEN,TPI)="Patient Count for "_PNAME_": " + N SCX + S SCX=$E(PNAME,1,22),$E(SCX,25)=$E(POSN,1,22),$E(SCX,49)=$E(TNAME,1,22) + S @STORE@("SUM0",IIEN,PRAC,TIEN,TPI)=SCX + ; + S @STORE@("TH",IIEN)="** Note: Patient Panel Count is a count of unique patients for each practitioner" + Q 0 Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPRAC2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPRAC2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPRAC2.m (revision 623) @@ -1,125 +1,113 @@ -SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,177,520**;AUG 13, 1993;Build 26 - ; - ;Practitioner Demographics Report - ; -GATHER(PARRAY,PRAC) ; - ;get practitioner data - N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV - N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS - N PRCPTE,SCDT,SCRATCH - S NXT=0 - F S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N) D - .S (PNAME,PHONE,SERV,ROOM)="" - .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV) - .;get provider name, office phone, room, service/section, person class - .; - .S ANODE=$G(@PARRAY@(NXT)) - .Q:ANODE="" - .S PIEN=+$P(ANODE,"^") ;position ien - .; - .;Get precepted provider information - .S PRCPCNT=0 - .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0 - .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)" - .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0 - .F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D - ..N SCPRCD,SCTP - ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3) - ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]" - ..S PRCPOS=$P($G(SCRATCH(1)),U,4) - ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0) - ..S PRCPCNT=PRCPCNT+PRCPCT - ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT - ..Q - .; - .S POS=$P(ANODE,"^",2) ;position name - .S STROL=$P(ANODE,"^",8) ;standard role name - .S USCL=$P(ANODE,"^",10) ;user class name - .S NODE=$G(^SCTM(404.57,PIEN,0)) - .S MAX=$P(NODE,"^",8) ;max patient assignments to position - .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients - .N CNAME,SCCLIEN - .D SETASCL(PIEN,.CNAME,.SCCLIEN) ;associated clinics - .; - .;Get preceptor - .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2) - .; - .S TIEN=+$P(ANODE,"^",3) ;team ien - .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name - .; - .;Set array for output - .S SCLN=0 - .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV) - .D SET1("Team",TNAME),SET2("Position",POS) - .D SET1("Role",STROL),SET2("User Class",USCL) - .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX) - .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN) - .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP) - .D SET3(4,"Assoc. Clinic: ") - .D SETCNAME(.CNAME) - .I $L(PCLASS(1)) D - ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D - ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D - ...I $L(PCLASS(3)) D SET3(18,PCLASS(3)) - ...Q - ..Q - .Q:'$D(^TMP("SCRATCH",$J)) - .D SET3(1,"") - .D SET4("Precepted Provider","Precepted Position","Pts. Precepted") - .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14)) - .S PRCPTE="" F S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE="" D - ..S SCTP=0 F S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP D - ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP) - ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U) - ...D SET4(PRCPTE,PRCPOS,PRCPCT_" ") - ...Q - ..Q - .D SET3(1,"") S SCI=" Total precepted patients: "_PRCPCNT - .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42) - .D SET3(1,SCI) - .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) - .Q - Q - ; -SETASCL(PIEN,CNAME,SCCLIEN) ;SET ASSOCIATED CLINICS - N I,CNT1 - S CNT1=0,I=0 - F S I=$O(^SCTM(404.57,PIEN,5,I)) Q:'I D - .S SCCLIEN(CNT1)=I,CNAME(CNT1)=$P($G(^SC(I,0)),U),CNT1=CNT1+1 - Q -SET1(LABEL,VALUE) ;Set output line - S SCLN=SCLN+1 - S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26) - Q - ; -SET2(LABEL,VALUE) ;Set second column of output line - S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26) - Q - ; -SET3(COL,VALUE) ;Set output line - N SCX - S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1))) - S @STORE@(PNAME,PIEN,SCLN)=SCX - Q - ; -SET4(V1,V2,V3) ;Set output line - S SCLN=SCLN+1,V1=" "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14) - S @STORE@(PNAME,PIEN,SCLN)=V1 - Q - ; -SETCNAME(CNAME) ;associated clinics - N A - S A="" F S A=$O(CNAME(A)) Q:A="" D SET3(12,CNAME(A)) - Q - ; -PINFO(VAE,PRACT,OPH,ROOM,SERV) ; - ;practitioner information from new person file - S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name - S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone - S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room - S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien - S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name - S PCLASS=$$GET^XUA4A72(VAE) ;Person class - N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) - Q +SCRPRAC2 ;ALB/CMM - Practitioner Demographics continued ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,177**;AUG 13, 1993 + ; + ;Practitioner Demographics Report + ; +GATHER(PARRAY,PRAC) ; + ;get practitioner data + N ANODE,TIEN,PNAME,POS,STROL,USCL,TNAME,MAX,PHONE,ASSIGN,ROOM,SERV + N NODE,PIEN,CNAME,PCLASS,PRCP,PRCPCNT,SCLN,SCI,NXT,PRCPCT,PRCPOS + N PRCPTE,SCDT,SCRATCH + S NXT=0 + F S NXT=$O(@PARRAY@(NXT)) Q:NXT=""!(NXT'?.N) D + .S (PNAME,PHONE,SERV,ROOM)="" + .D PINFO(PRAC,.PNAME,.PHONE,.ROOM,.SERV) + .;get provider name, office phone, room, service/section, person class + .; + .S ANODE=$G(@PARRAY@(NXT)) + .Q:ANODE="" + .S PIEN=+$P(ANODE,"^") ;position ien + .; + .;Get precepted provider information + .S PRCPCNT=0 + .S SCDT="SCDT",(SCDT("BEGIN"),SCDT("END"))="DT",SCDT("INCL")=0 + .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) S SCI="^TMP(""SCRATCH1"",$J)" + .S SCI=$$PRECHIS^SCMCLK(PIEN,.SCDT,SCI),SCI=0 + .F S SCI=$O(^TMP("SCRATCH1",$J,SCI)) Q:'SCI D + ..N SCPRCD,SCTP + ..S SCPRCD=^TMP("SCRATCH1",$J,SCI),SCTP=$P(SCPRCD,U,3) + ..S PRCPTE=$P(SCPRCD,U,2) S:'$L(PRCPTE) PRCPTE="[unknown]" + ..S PRCPOS=$P($G(SCRATCH(1)),U,4) + ..S PRCPCT=$$PCPOSCNT^SCAPMCU1(SCTP,DT,0) + ..S PRCPCNT=PRCPCNT+PRCPCT + ..S ^TMP("SCRATCH",$J,PRCPTE,SCTP)=PRCPOS_U_PRCPCT + ..Q + .; + .S POS=$P(ANODE,"^",2) ;position name + .S STROL=$P(ANODE,"^",8) ;standard role name + .S USCL=$P(ANODE,"^",10) ;user class name + .S NODE=$G(^SCTM(404.57,PIEN,0)) + .S MAX=$P(NODE,"^",8) ;max patient assignments to position + .S ASSIGN=+$$PCPOSCNT^SCAPMCU1(PIEN,DT,0) ;assigned patients + .S CNAME=$P($G(^SC(+$P(NODE,U,9),0)),U) ;associated clinic + .; + .;Get preceptor + .S PRCP=$P($$OKPREC2^SCMCLK(PIEN,DT),U,2) + .; + .S TIEN=+$P(ANODE,"^",3) ;team ien + .S TNAME=$P($G(^SCTM(404.51,TIEN,0)),"^") ;team name + .; + .;Set array for output + .S SCLN=0 + .D SET1("Name",PNAME),SET2("Serv./Sect.",SERV) + .D SET1("Team",TNAME),SET2("Position",POS) + .D SET1("Role",STROL),SET2("User Class",USCL) + .D SET1("Room",ROOM),SET2("Pts. Allowed",MAX) + .D SET1("Phone",PHONE),SET2("Pts. Assigned",ASSIGN) + .I $L($G(PRCP)) D SET3(1,"Preceptor: "_PRCP) + .D SET3(4,"Assoc.") + .D SET3(4,"Clinic: "_CNAME) + .I $L(PCLASS(1)) D + ..D SET3(4,"Person"),SET3(5,"Class: "_PCLASS(1)) D + ..I $L(PCLASS(2)) D SET3(15,PCLASS(2)) D + ...I $L(PCLASS(3)) D SET3(18,PCLASS(3)) + ...Q + ..Q + .Q:'$D(^TMP("SCRATCH",$J)) + .D SET3(1,"") + .D SET4("Precepted Provider","Precepted Position","Pts. Precepted") + .S SCI="",$P(SCI,"-",31)="" D SET4(SCI,SCI,$E(SCI,1,14)) + .S PRCPTE="" F S PRCPTE=$O(^TMP("SCRATCH",$J,PRCPTE)) Q:PRCPTE="" D + ..S SCTP=0 F S SCTP=$O(^TMP("SCRATCH",$J,PRCPTE,SCTP)) Q:'SCTP D + ...S PRCPOS=^TMP("SCRATCH",$J,PRCPTE,SCTP) + ...S PRCPCT=+$P(PRCPOS,U,2),PRCPOS=$P(PRCPOS,U) + ...D SET4(PRCPTE,PRCPOS,PRCPCT_" ") + ...Q + ..Q + .D SET3(1,"") S SCI=" Total precepted patients: "_PRCPCNT + .S $E(SCI,37)=$J(("Total assigned/precepted patients: "_(PRCPCNT+ASSIGN)),42) + .D SET3(1,SCI) + .K ^TMP("SCRATCH",$J),^TMP("SCRATCH1",$J) + .Q + Q + ; +SET1(LABEL,VALUE) ;Set output line + S SCLN=SCLN+1 + S @STORE@(PNAME,PIEN,SCLN)=$J(LABEL,9)_": "_$E(VALUE,1,26) + Q + ; +SET2(LABEL,VALUE) ;Set second column of output line + S $E(@STORE@(PNAME,PIEN,SCLN),40)=$J(LABEL,13)_": "_$E(VALUE,1,26) + Q + ; +SET3(COL,VALUE) ;Set output line + N SCX + S SCLN=SCLN+1,SCX="",$E(SCX,COL)=$E(VALUE,1,(80-(COL-1))) + S @STORE@(PNAME,PIEN,SCLN)=SCX + Q + ; +SET4(V1,V2,V3) ;Set output line + S SCLN=SCLN+1,V1=" "_V1,$E(V1,35)=V2,$E(V1,67)=$J(V3,14) + S @STORE@(PNAME,PIEN,SCLN)=V1 + Q + ; +PINFO(VAE,PRACT,OPH,ROOM,SERV) ; + ;practitioner information form new person file + S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name + S OPH=$P($G(^VA(200,VAE,.13)),"^",2) ;office phone + S ROOM=$P($G(^VA(200,VAE,.14)),"^") ;room + S SERV=$P($G(^VA(200,VAE,5)),"^") ;service/section ien + S SERV=$P($G(^DIC(49,+SERV,0)),"^") ;service/section name + S PCLASS=$$GET^XUA4A72(VAE) ;Person class + N SCI F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT.m (revision 623) @@ -1,147 +1,143 @@ -SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,52,177,231,520**;AUG 13, 1993;Build 26 - ; - ;Summary Listing of Teams Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Role and Print device - ; - N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER - K VAUTD,VAUTT,VAUTR,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTR) Q - ; -QUE(INST,TEAM,ROLE) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - N ZTSAVE,II - F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPSLT" - S ZTDESC="Summary Listing Of Teams",ZTIO=IOP - N II - F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Summary Listing of Teams" - S STORE="^TMP("_$J_",""SCRPSLT"")" - K @STORE - S @STORE=0 - I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP - Q - ; -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA - Q - ; -FIND ; - N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC - S TM="" - F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D - .;$O through team position file - .I '$D(TEAM(TM))&(TEAM'=1) Q - .;Q above, not a selected team - .;selected team - .S EN="" - .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0 - .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D - ..I '$D(^SCTM(404.57,EN,0)) Q - ..S NODE=$G(^SCTM(404.57,EN,0)) - ..Q:NODE="" - ..S ROL=+$P(NODE,"^",3) ;role ien - ..I '$D(ROLE(ROL))&(ROLE'=1) Q - ..;Q above not a selected role - ..;find active position during date range - ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT) - ..I +TMP=0 Q - ..S EN2=+$P(TMP,"^",4) - ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC) - ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT) - ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8) - ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0 - ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC) - Q - ; -PRINTIT(STORE,TITL) ; - N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS,SCAC - S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF - D TITLE^SCRPU3(.PAGE,TITL) - D FORHEAD^SCRPSLT2 - F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D - .S INST=$O(@STORE@("I",EINST,"")) - .I INST="" Q - .S (TEM,ETEAM)="" - .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D - ..S TEM=$O(@STORE@("T",INST,ETEAM,"")) - ..I TEM="" Q - ..K NEW - ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" - ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" - ..S NPAGE=1 I STOP Q - ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" - ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" - ..I STOP Q - ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM) - ..S (PRACT,EPRACT)="" - ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D - ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,"")) - ...I PRACT="" Q - ...S POS="" - ...F S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP) D - ....W !,$G(@STORE@(INST,TEM,PRACT,POS)) - ....S SCAC="" - ....F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,SCAC)) Q:SCAC=""!(STOP) D - .....W !,$G(@STORE@(INST,TEM,PRACT,POS,SCAC)) - .....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) - .....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) - .....I STOP Q - ....;W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info - ..Q:STOP - ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1) - ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1) - ..D TOTAL^SCRPSLT2(INST,TEM) - .I STOP Q - .S NPAGE=1 - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR - Q +SCRPSLT ;ALB/CMM - Summary Listing of Teams ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,52,177,231**;AUG 13, 1993 + ; + ;Summary Listing of Teams Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Role and Print device + ; + N VAUTD,VAUTT,VAUTR,QTIME,PRNT,NUMBER + K VAUTD,VAUTT,VAUTR,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTR) Q + ; +QUE(INST,TEAM,ROLE) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + N ZTSAVE,II + F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPSLT","Summary Listing of Teams",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,ROLE,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPSLT" + S ZTDESC="Summary Listing Of Teams",ZTIO=IOP + N II + F II="INST","TEAM","ROLE","INST(","TEAM(","ROLE(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Summary Listing of Teams" + S STORE="^TMP("_$J_",""SCRPSLT"")" + K @STORE + S @STORE=0 + I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP + Q + ; +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA + Q + ; +FIND ; + N TM,EN2,EN,ROL,NODE,TEND,ACT,INA,TPASS,TPCN,TMAX,TMP,TOA,TNPC + S TM="" + F S TM=$O(^SCTM(404.57,"C",TM)) Q:TM="" D + .;$O through team position file + .I '$D(TEAM(TM))&(TEAM'=1) Q + .;Q above, not a selected team + .;selected team + .S EN="" + .S TPASS(TM)=0,TMAX(TM)=0,TPCN(TM)=0 + .F S EN=$O(^SCTM(404.57,"C",TM,EN)) Q:EN="" D + ..I '$D(^SCTM(404.57,EN,0)) Q + ..S NODE=$G(^SCTM(404.57,EN,0)) + ..Q:NODE="" + ..S ROL=+$P(NODE,"^",3) ;role ien + ..I '$D(ROLE(ROL))&(ROLE'=1) Q + ..;Q above not a selected role + ..;find active position during date range + ..S TMP=$$DATES^SCAPMCU1(404.52,EN,DT) + ..I +TMP=0 Q + ..S EN2=+$P(TMP,"^",4) + ..D KEEP^SCRPSLT2(NODE,EN,EN2,ROL,TM,.TPCN,.TNPC) + ..S TPASS(TM)=$$TEAMCNT^SCAPMCU1(TM,DT) + ..S TMAX(TM)=+$P($G(^SCTM(404.51,+TM,0)),U,8) + ..S TOA(TM)=TMAX(TM)-TPASS(TM) S:TOA(TM)<0 TOA(TM)=0 + ..D TEAMT^SCRPSLT2(TM,.TPASS,.TMAX,.TPCN,.TOA,.TNPC) + Q + ; +PRINTIT(STORE,TITL) ; + N INST,EINST,ETEAM,TEM,EPRACT,PRACT,NXT,PAGE,NPAGE,NEW,POS + S (INST,EINST)="",(NPAGE,STOP)=0,PAGE=1 W:$E(IOST)="C" @IOF + D TITLE^SCRPU3(.PAGE,TITL) + D FORHEAD^SCRPSLT2 + F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D + .S INST=$O(@STORE@("I",EINST,"")) + .I INST="" Q + .S (TEM,ETEAM)="" + .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D + ..S TEM=$O(@STORE@("T",INST,ETEAM,"")) + ..I TEM="" Q + ..K NEW + ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" + ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" + ..S NPAGE=1 I STOP Q + ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) S NEW="" + ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) S NEW="" + ..I STOP Q + ..I '$D(NEW) D HEADER^SCRPSLT2(INST,TEM) + ..S (PRACT,EPRACT)="" + ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D + ...S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,"")) + ...I PRACT="" Q + ...S POS="" + ...F S POS=$O(@STORE@(INST,TEM,PRACT,POS)) Q:POS=""!(STOP) D + ....I IOST'?1"C-".E,$Y>(IOSL-4) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE) + ....I IOST?1"C-".E,$Y>(IOSL-4) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM) + ....I STOP Q + ....W !,$G(@STORE@(INST,TEM,PRACT,POS)) ;writes info + ..Q:STOP + ..I IOST'?1"C-".E,$Y>(IOSL-8) D NEWP^SCRPSLT2(INST,TEM,TITL,.PAGE,1) + ..I IOST?1"C-".E,$Y>(IOSL-8) D HOLD1^SCRPSLT2(.PAGE,TITL,INST,TEM,1) + ..D TOTAL^SCRPSLT2(INST,TEM) + .I STOP Q + .S NPAGE=1 + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" D ^DIR + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPSLT2.m (revision 623) @@ -1,170 +1,162 @@ -SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am - ;;5.3;Scheduling;**41,174,177,231,520**;AUG 13, 1993;Build 26 - ; - ;Summary Listing of Teams Report - ; -KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ; - ;TNODE - zero node of the team position file - ;APOS - ien of team position file - ;TPOS - ien of position assignment history file - ;ROL - ien of role - ;TM - ien of team - ; - N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX - N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI - ; - S TEN=+$P(TNODE,"^",2) ;team file pointer - S TMN=$G(^SCTM(404.51,TEN,0)) - S TNAME=$P(TMN,"^") ;team name - S DIV=+$P(TMN,"^",7) ;division ien - S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division - D KTEAM(TNAME,TDIV,TM,DIV) - ; - S POS=$P(TNODE,"^") ;position name - ;SD*5.3*231 - call SCMCLK to determine in AP or not - S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>0:" AP",1:"PCP") ;PC? - ;S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic - D SETASCL^SCRPRAC2(APOS,.PCLIN) - S PCLIN=$G(PCLIN(0)) - S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name - ; - S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)" - K @SCI - S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT" - S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI) - I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D - .N SCPRCD - .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE - .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients - .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC - .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients - .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0 - .S PRCNPC=PRCNPC+SCNPC - .Q - ; - S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data - ; - S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file - S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name - I PRACT="" S PRACT="[Not Assigned]" - ; - S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0 - S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0 - S TPCN(TM)=$G(TPCN(TM))+PCN - S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0 - S NPC=NPC-PCN S:NPC<0 NPC=0 - S TNPC(TM)=$G(TNPC(TM))+NPC - ; - D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) - N SCAC - S SCAC=0 - F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(APOS,POS,PCLIN(SCAC),VAE,DIV,TM) - Q - ; -TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ; - ;set team totals into global - S @STORE@("TOTALS",TM,"H1")=" Team Totals:" - S @STORE@("TOTALS",TM,"H2")="------------------------------------" - S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0) - S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0) - S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0) - S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0) - S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0) - Q - ; -FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ; - ; - NEW TMP - I PRACT="" S PRACT="Bad Data" - S @STORE@("PN",DIV,TM,PRACT,VAE)="" - S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name - S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position - S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC? - S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role - S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic - S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts. - S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts. - S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts. - ; - ;bp/djb 'Precepted Patients' column should be zero for APs. - ;Old code begins - ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC - ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC - ;Old code ends - ;New code begins - S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero - .S TMP(1)=$P(XDAT,U,2) - .S TMP(2)=$P(XDAT,U,3) - S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC - S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC - ;New code ends - Q -FORMATAC(APOS,POS,PCLIN,VAE,DIV,TM) ;clinic multiples - S $E(@STORE@(DIV,TM,VAE,APOS,SCAC),72)=$E(PCLIN,1,30) - Q - ; -TOTAL(INST,TEM) ; - ;Prints team totals - N NXT - S NXT="" - W ! - F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D - .;bp/djb Stop displaying certain 'Team Totals:' lines. - .;New code begin - .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned" - .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed" - .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments" - .;New code end - .W !,$G(@STORE@("TOTALS",TEM,NXT)) - W ! - Q - ; -KTEAM(TNAME,TDIV,TIEN,IEND) ; - ;store team information - I TNAME="" S TNAME="[BAD DATA]" - I TDIV="" S TDIV="[BAD DATA]" - S @STORE@("I",TDIV,IEND)="" - S @STORE@("T",IEND,TNAME,TIEN)="" - S @STORE@(IEND)=" Division: "_TDIV - S @STORE@(IEND,TIEN)="Team Name: "_TNAME - Q - ; -FORHEAD ; - S @STORE@("H3")="Practitioner" - S $E(@STORE@("H3"),23)="Position" - S $E(@STORE@("H3"),45)="PC?" - S $E(@STORE@("H3"),50)="Standard Role" - S $E(@STORE@("H3"),72)="Associated Clinic" - S $E(@STORE@("H1"),101)="Max." - S $E(@STORE@("H2"),101)="Pts." - S $E(@STORE@("H3"),99)="Allow." - S $E(@STORE@("H1"),107)="--Assigned--" - S $E(@STORE@("H2"),107)="--Patients--" - S $E(@STORE@("H3"),107)="PC NonPC" - S $E(@STORE@("H1"),121)="--Precepted-" - S $E(@STORE@("H2"),121)="--Patients--" - S $E(@STORE@("H3"),121)="PC NonPC" - S $P(@STORE@("H4"),"=",133)="" - Q -HEADER(INST,TEM,TEND) ; - N NXT - S NXT="H",TEND=$G(TEND) - W !!,@STORE@(INST) - W !!,@STORE@(INST,TEM) - I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D - .W !,@STORE@(NXT) - W ! - Q -NEWP(INST,TEM,TITL,PAGE,TEND) ; - S TEND=$G(TEND) - D NEWP1^SCRPU3(.PAGE,TITL) - I STOP Q - D HEADER(INST,TEM,TEND) - Q -HOLD1(PAGE,TITL,INST,TEM,TEND) ; - ;device is home, reached end of page - S TEND=$G(TEND) - D HOLD^SCRPU3(.PAGE,TITL) - I STOP Q - D HEADER(INST,TEM,TEND) - Q +SCRPSLT2 ;ALB/CMM - Summary Listing of Teams Continued ; 9/15/99 10:43am + ;;5.3;Scheduling;**41,174,177,231**;AUG 13, 1993 + ; + ;Summary Listing of Teams Report + ; +KEEP(TNODE,APOS,TPOS,ROL,TM,TPCN,TNPC) ; + ;TNODE - zero node of the team position file + ;APOS - ien of team position file + ;TPOS - ien of position assignment history file + ;ROL - ien of role + ;TM - ien of team + ; + N POS,TNAME,TPHONE,TPC,TDIV,TEN,TMN,DIV,PPC,PCLIN,VAE,PRACT,NPC,MAX + N PCN,ROLN,PRCTP,PRCPC,PRCNPC,PRCPTE,SCPC,SCNPC,XDAT,SCDT,SCI + ; + S TEN=+$P(TNODE,"^",2) ;team file pointer + S TMN=$G(^SCTM(404.51,TEN,0)) + S TNAME=$P(TMN,"^") ;team name + S DIV=+$P(TMN,"^",7) ;division ien + S TDIV=$P($G(^DIC(4,DIV,0)),"^") ;team division + D KTEAM(TNAME,TDIV,TM,DIV) + ; + S POS=$P(TNODE,"^") ;position name + ;SD*5.3*231 - call SCMCLK to determine in AP or not + S PPC=$S($P(TNODE,"^",4)<1:"NPC",+$$OKPREC3^SCMCLK(APOS,DT)>1:" AP",1:"PCP") ;PC? + S PCLIN=$P($G(^SC(+$P(TNODE,"^",9),0)),"^") ;associated clinic + S ROLN=$P($G(^SD(403.46,+ROL,0)),U) ;role name + ; + S (PRCPC,PRCNPC)="",SCI="^TMP(""SCRATCH"",$J)" + K @SCI + S (SCDT("BEGIN"),SCDT("END"))=DT,SCDT("INCL")=0,SCDT="SCDT" + S SCI=$$PRECHIS^SCMCLK(APOS,.SCDT,SCI) + I SCI=1 S SCI=0 F S SCI=$O(^TMP("SCRATCH",$J,SCI)) Q:'SCI D + .N SCPRCD + .S SCPRCD=^TMP("SCRATCH",$J,SCI),PRCPTE=$P(SCPRCD,U,3) Q:'PRCPTE + .S SCPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,1) ;precepted PC patients + .S:SCPC<0 SCPC=0 S PRCPC=PRCPC+SCPC + .S SCNPC=$$PCPOSCNT^SCAPMCU1(PRCPTE,DT,0) ;all precepted patients + .S:SCNPC<0 SCNPC=0 S SCNPC=SCNPC-SCPC S:SCNPC<0 SCNPC=0 + .S PRCNPC=PRCNPC+SCNPC + .Q + ; + S XDAT=ROLN_U_PRCPC_U_PRCNPC ;extra data + ; + S VAE=+$P($G(^SCTM(404.52,TPOS,0)),"^",3) ;ien of new person file + S PRACT=$P($G(^VA(200,VAE,0)),"^") ;practitioner name + I PRACT="" S PRACT="[Not Assigned]" + ; + S MAX=+$P(TNODE,"^",8) I MAX<0 S MAX=0 + S PCN=$$PCPOSCNT^SCAPMCU1(APOS,DT) S:PCN=-1 PCN=0 + S TPCN(TM)=$G(TPCN(TM))+PCN + S NPC=$$PCPOSCNT^SCAPMCU1(APOS,DT,0) S:NPC=-1 NPC=0 + S NPC=NPC-PCN S:NPC<0 NPC=0 + S TNPC(TM)=$G(TNPC(TM))+NPC + ; + D FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MAX,PCN,XDAT) + Q + ; +TEAMT(TM,TPASS,TMAX,TPCN,TOA,TNPC) ; + ;set team totals into global + S @STORE@("TOTALS",TM,"H1")=" Team Totals:" + S @STORE@("TOTALS",TM,"H2")="------------------------------------" + S @STORE@("TOTALS",TM,"H3")=" Primary Care Assignments: "_$J($G(TPCN(TM)),6,0) + S @STORE@("TOTALS",TM,"H4")=" Non-PC Assignments: "_$J($G(TNPC(TM)),6,0) + S @STORE@("TOTALS",TM,"H5")=" Unique Patients Assigned: "_$J($G(TPASS(TM)),6,0) + S @STORE@("TOTALS",TM,"H6")=" Maximum Patients Allowed: "_$J($G(TMAX(TM)),6,0) + S @STORE@("TOTALS",TM,"H7")=" Total Open Assignments: "_$J($G(TOA(TM)),6,0) + Q + ; +FORMAT(APOS,POS,PCLIN,VAE,PRACT,PPC,DIV,TM,NPC,MX,PC,XDAT) ; + ; + NEW TMP + I PRACT="" S PRACT="Bad Data" + S @STORE@("PN",DIV,TM,PRACT,VAE)="" + S @STORE@(DIV,TM,VAE,APOS)=$E(PRACT,1,20) ;practitioner name + S $E(@STORE@(DIV,TM,VAE,APOS),23)=$E(POS,1,20) ;position + S $E(@STORE@(DIV,TM,VAE,APOS),45)=PPC ;PC? + S $E(@STORE@(DIV,TM,VAE,APOS),50)=$E($P(XDAT,U),1,20) ;role + S $E(@STORE@(DIV,TM,VAE,APOS),72)=$E(PCLIN,1,25) ;assoc. clinic + S $E(@STORE@(DIV,TM,VAE,APOS),99)=$J(MX,6,0) ;max pts. + S $E(@STORE@(DIV,TM,VAE,APOS),107)=$J(PC,5,0) ;PC pts. + S $E(@STORE@(DIV,TM,VAE,APOS),114)=$J(NPC,5,0) ;non-PC pts. + ; + ;bp/djb 'Precepted Patients' column should be zero for APs. + ;Old code begins + ;S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J($P(XDAT,U,2),5,0) ;precept PC + ;S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J($P(XDAT,U,3),5,0) ;precept NPC + ;Old code ends + ;New code begins + S (TMP(1),TMP(2))=0 I PPC'["AP" D ;APs should be zero + .S TMP(1)=$P(XDAT,U,2) + .S TMP(2)=$P(XDAT,U,3) + S $E(@STORE@(DIV,TM,VAE,APOS),121)=$J(TMP(1),5,0) ;precepted PC + S $E(@STORE@(DIV,TM,VAE,APOS),128)=$J(TMP(2),5,0) ;precepted NPC + ;New code ends + Q + ; +TOTAL(INST,TEM) ; + ;Prints team totals + N NXT + S NXT="" + W ! + F S NXT=$O(@STORE@("TOTALS",TEM,NXT)) Q:NXT="" D + .;bp/djb Stop displaying certain 'Team Totals:' lines. + .;New code begin + .Q:$G(@STORE@("TOTALS",TEM,NXT))["Unique Patients Assigned" + .Q:$G(@STORE@("TOTALS",TEM,NXT))["Maximum Patients Allowed" + .Q:$G(@STORE@("TOTALS",TEM,NXT))["Total Open Assignments" + .;New code end + .W !,$G(@STORE@("TOTALS",TEM,NXT)) + W ! + Q + ; +KTEAM(TNAME,TDIV,TIEN,IEND) ; + ;store team information + I TNAME="" S TNAME="[BAD DATA]" + I TDIV="" S TDIV="[BAD DATA]" + S @STORE@("I",TDIV,IEND)="" + S @STORE@("T",IEND,TNAME,TIEN)="" + S @STORE@(IEND)=" Division: "_TDIV + S @STORE@(IEND,TIEN)="Team Name: "_TNAME + Q + ; +FORHEAD ; + S @STORE@("H3")="Practitioner" + S $E(@STORE@("H3"),23)="Position" + S $E(@STORE@("H3"),45)="PC?" + S $E(@STORE@("H3"),50)="Standard Role" + S $E(@STORE@("H3"),72)="Associated Clinic" + S $E(@STORE@("H1"),101)="Max." + S $E(@STORE@("H2"),101)="Pts." + S $E(@STORE@("H3"),99)="Allow." + S $E(@STORE@("H1"),107)="--Assigned--" + S $E(@STORE@("H2"),107)="--Patients--" + S $E(@STORE@("H3"),107)="PC NonPC" + S $E(@STORE@("H1"),121)="--Precepted-" + S $E(@STORE@("H2"),121)="--Patients--" + S $E(@STORE@("H3"),121)="PC NonPC" + S $P(@STORE@("H4"),"=",133)="" + Q +HEADER(INST,TEM,TEND) ; + N NXT + S NXT="H",TEND=$G(TEND) + W !!,@STORE@(INST) + W !!,@STORE@(INST,TEM) + I 'TEND F S NXT=$O(@STORE@(NXT)) Q:NXT'?1"H".E D + .W !,@STORE@(NXT) + W ! + Q +NEWP(INST,TEM,TITL,PAGE,TEND) ; + S TEND=$G(TEND) + D NEWP1^SCRPU3(.PAGE,TITL) + I STOP Q + D HEADER(INST,TEM,TEND) + Q +HOLD1(PAGE,TITL,INST,TEM,TEND) ; + ;device is home, reached end of page + S TEND=$G(TEND) + D HOLD^SCRPU3(.PAGE,TITL) + I STOP Q + D HEADER(INST,TEM,TEND) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA.m (revision 623) @@ -1,160 +1,160 @@ -SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,52,114,174,181,177,526**;AUG 13, 1993;Build 8 - ; - ;Patient Listing w/Team Assignment Data Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Role, Practitioner and Print device - ; - N PRNT,QTIME,NUMBER - K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q - ; -QUE(INST,TEAM,ROLE,PRACT) ; - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PRACT - practitioners selected (variable and array) - N ZTSAVE,II - F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PRACT - practitioners selected (variable and array) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPTA" - S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP - N II - F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Patient Listing For Team Assignments" - S STORE="^TMP("_$J_",""SCRPTA"")" - K @STORE - S @STORE=0 - I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP - Q - ; -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT - Q - ; -FIND ; - N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN - S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1" - K @TLIST,@TERR - F S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N) D - .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT - .Q:ERR1=0 - .S CNT=0 - .F S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N) D - ..S TNODE=$G(@TLIST@(CNT)) - ..Q:TNODE="" - ..S PIEN=+$P(TNODE,"^") ;patient ien - ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42 - ..D CHK^SCRPTA2(PTAIEN,PIEN) - .K @TLIST,@TERR - K @TLIST,@TERR - Q - ; -PRINTIT(STORE,TITL) ; - N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS - S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF - D SHEAD ;setup headers - F S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP) D - .S INT=$O(@STORE@("I",INTN,"")) ;institution - .Q:INT="" - .S TMN="" - .F S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP) D - ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team - ..Q:TM="" - ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) - ..Q:STOP - ..S PRN="" - ..D HEADER - ..F S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP) D - ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner - ...Q:PR="" - ...S POS="" - ...F S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP) D - ....D PRNT(INT,TM,PR,POS) - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q - ; -PRNT(INT,TM,PR,POS) ; - ;INT - institution ien - ;TM - team ien - ;PR - practitioner ien - ;POS - position ien - ; - N PTIEN,PTNAME - S PTNAME="" - F S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP) D - .S PTIEN="" - .F S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP) D - ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER - ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER - ..Q:STOP - ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) - .Q - Q - ; -HEADER ; - ;write column headers - N EN - W ! - F EN="H1","H2","H3" D - .W !,$G(@STORE@(EN)) - Q -SHEAD ; - ;setup column headers - S @STORE@("H2")="Patient Name" - S $E(@STORE@("H2"),19)="Pt ID" - S $E(@STORE@("H1"),31)="Date" - S $E(@STORE@("H2"),31)="Assigned" - S $E(@STORE@("H2"),43)="PC?" - S $E(@STORE@("H2"),49)="Practitioner" - S $E(@STORE@("H2"),70)="Position" - S $E(@STORE@("H2"),92)="Standard Role" - S $E(@STORE@("H2"),113)="Preceptor" - S $P(@STORE@("H3"),"=",133)="" - Q +SCRPTA ;ALB/CMM - Patient Listing w/Team Assignment Data ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,52,114,174,181,177**;AUG 13, 1993 + ; + ;Patient Listing w/Team Assignment Data Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Role, Practitioner and Print device + ; + N PRNT,QTIME,NUMBER + K VAUTD,VAUTT,VAUTR,VAUTP,VAUTPP,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + W ! K Y S VAUTPP="" D PRACT^SCRPU1 K VAUTPP I '$D(VAUTP) G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTR,.VAUTP) Q + ; +QUE(INST,TEAM,ROLE,PRACT) ; + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PRACT - practitioners selected (variable and array) + N ZTSAVE,II + F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPTA","Patient Listing for Team Assignments",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,ROLE,PRACT,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PRACT - practitioners selected (variable and array) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PRACT)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPTA" + S ZTDESC="Patient Listing w/Team Assignment",ZTIO=IOP + N II + F II="INST","TEAM","ROLE","INST(","TEAM(","PRACT","PRACT(","ROLE(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Patient Listing For Team Assignments" + S STORE="^TMP("_$J_",""SCRPTA"")" + K @STORE + S @STORE=0 + I TEAM=1 D TALL^SCRPPAT3 S TEAM=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,Y,SCUP + Q + ; +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,NODATA,PRACT + Q + ; +FIND ; + N NXT,TLIST,TERR,CNT,ERR1,TNODE,NODE1,PIEN,PTAIEN + S NXT=0,TLIST="^TMP("_$J_",""SCRPTA"",""LIST1"")",TERR="ERR1" + K @TLIST,@TERR + F S NXT=$O(TEAM(NXT)) Q:NXT=""!(NXT'?.N) D + .S ERR1=$$PTTM^SCAPMC2(NXT,,.TLIST,.TERR) ;Patients assigned to team NXT + .Q:ERR1=0 + .S CNT=0 + .F S CNT=$O(@TLIST@(CNT)) Q:CNT=""!(CNT'?.N) D + ..S TNODE=$G(@TLIST@(CNT)) + ..Q:TNODE="" + ..S PIEN=+$P(TNODE,"^") ;patient ien + ..S PTAIEN=+$P(TNODE,"^",3) ;ien Patient Team Assignment #404.42 + ..D CHK^SCRPTA2(PTAIEN,PIEN) + .K @TLIST,@TERR + K @TLIST,@TERR + Q + ; +PRINTIT(STORE,TITL) ; + N NXT,PAGE,NPAGE,INTN,TMN,INT,TM,PRN,PR,POS + S (NPAGE,STOP,PAGE)=0,INTN="" W:$E(IOST)="C" @IOF + D SHEAD ;setup headers + F S INTN=$O(@STORE@("I",INTN)) Q:INTN=""!(STOP) D + .S INT=$O(@STORE@("I",INTN,"")) ;institution + .Q:INT="" + .S TMN="" + .F S TMN=$O(@STORE@("T",INT,TMN)) Q:TMN=""!(STOP) D + ..S TM=$O(@STORE@("T",INT,TMN,"")) ;team + ..Q:TM="" + ..D NEWP1^SCRPU3(.PAGE,TITL,132) W !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) + ..Q:STOP + ..S PRN="" + ..D HEADER + ..F S PRN=$O(@STORE@("P",INT,TM,PRN)) Q:PRN=""!(STOP) D + ...S PR=$O(@STORE@("P",INT,TM,PRN,"")) ;practitioner + ...Q:PR="" + ...S POS="" + ...F S POS=$O(@STORE@("P",INT,TM,PRN,PR,POS)) Q:POS=""!(STOP) D + ....D PRNT(INT,TM,PR,POS) + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q + ; +PRNT(INT,TM,PR,POS) ; + ;INT - institution ien + ;TM - team ien + ;PR - practitioner ien + ;POS - position ien + ; + N PTIEN,PTNAME + S PTNAME="" + F S PTNAME=$O(@STORE@(INT,TM,PR,POS,PTNAME)) Q:PTNAME=""!(STOP) D + .S PTIEN="" + .F S PTIEN=$O(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) Q:PTIEN=""!(STOP) D + ..I (IOST'?1"C-".E),$Y>(IOSL-4) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER + ..I (IOST?1"C-".E),$Y>(IOSL-4) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INT)),!!,$G(@STORE@(INT,TM)) D:'STOP HEADER + ..Q:STOP + ..W !,$G(@STORE@(INT,TM,PR,POS,PTNAME,PTIEN)) + .Q + Q + ; +HEADER ; + ;write column headers + N EN + W ! + F EN="H1","H2","H3" D + .W !,$G(@STORE@(EN)) + Q +SHEAD ; + ;setup column headers + S @STORE@("H2")="Patient Name" + S $E(@STORE@("H2"),24)="Pt ID" + S $E(@STORE@("H1"),31)="Date" + S $E(@STORE@("H2"),31)="Assigned" + S $E(@STORE@("H2"),43)="PC?" + S $E(@STORE@("H2"),49)="Practitioner" + S $E(@STORE@("H2"),70)="Position" + S $E(@STORE@("H2"),92)="Standard Role" + S $E(@STORE@("H2"),113)="Preceptor" + S $P(@STORE@("H3"),"=",133)="" + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTA2.m (revision 623) @@ -1,153 +1,152 @@ -SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM - ;;5.3;Scheduling;**41,88,140,148,174,181,177,526**;AUG 13, 1993;Build 8 - ; - ;Patient Listing w/Team Assignment Data Report continued - ; -CHK(PTIEN,PIEN) ;assigned to a position - ;PTIEN - ien of 404.42 Patient Team Assignment file - ;PIEN - ien of patient file #2 - ; - N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN - S START="" - Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="") - I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q - F S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START="" D - .S NODE=$G(^SCPT(404.43,START,0)) - .Q:NODE="" - .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)0:" AP",1:"PCP") ; PC? - .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) ;preceptor name - .; - .S ROL=+$P(TPNODE,"^",3) ;role for position (ien) - .Q:'$D(ROLE(ROL))&(ROLE'=1) ;not a selected role - .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name - .; - .S PRAC=$$PRACI(TPIEN) ;practitioner information - .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q - .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q - .; ^ not a selected practitioner - .; - .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^") - .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) - Q -PRACI(TPIEN) ; - ;TPIEN - team position ien (404.57) - ; - N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN - S TPLIST="TPLST",TPERR="ERR2" - K @TPLIST,@TPERR - S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR) - Q:ERR=0!($D(@TPERR)) -1 - S NODE=$G(@TPLIST@(1)) - Q:NODE="" "0^[Not Assigned]" - S NAME=$P(NODE,"^",2) ;practitioner name - S NPIEN=+$P(NODE,"^") ;practitioner ien - S POS=$P(NODE,"^",4) ;position name - S POSIEN=+$P(NODE,"^",3) ;position ien - I POS="" S POS="[Not Assigned]",POSIEN=0 - I NAME="" S NAME="[Not Assigned]",NPIEN=0 - K @TPLIST,@TPERR - Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN - ; -FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ; - ;START - patient team assignment position ien - ;NODE - patient team position assignment node - ;TPIEN - team position ien (404.57) - ;POS - team position - ;TPNODE - team position node (404.57) - ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN - ;ROLN - role name - ;PCAP - PC/AP/NPC assignment? - ;PRCN - preceptor name - ; - N PTNAME,PID,ADATE - S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name - S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") - ;9 digit ssn SD*5.3*526 - dmr - ;S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation - ; - S ADATE=$P(NODE,"^",3) ;position assignment date - fm format - ;convert to external format - I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0") - ; - S PNAME=$P(PRAC,"^",2) ;practitioner name - S PNIEN=$P(PRAC,"^") ;practitioner ien - ; - S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51 - S TMN=$G(^SCTM(404.51,TIEN,0)) - Q:TMN="" - S TNAME=$P(TMN,"^") ;team name - S PC=$P(TMN,"^",5) ;primary care team 1/0 - S IIEN=+$P(TMN,"^",7) ;institution ien - S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution - ; - D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN) - Q - ; -FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ; - ;IIEN - institution ien - ;INAME - institution name - ;TNAME - team name - ;TIEN - team ien - ;PC - primary care 1/0 - ;PTNAME - patient name - ;PID - last 4 pid plus 5th pseudo - ;PNAME - practitioner name - ;PIEN - practitioner ien - ;POS - position name - ;TPIEN - position ien - ;ADATE - assignment date - ;PTIEN - patient ien - ;ROLN - role name - ;PCAP - PC/AP/NPC assignment? - ;PRCN - preceptor name - ; - I INAME="" S INAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - I PNAME="" S PNAME="[BAD DATA]" - I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)="" - I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)="" - I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)="" - S @STORE@(IIEN)="Division: "_INAME - S @STORE@(IIEN,TIEN)="Team: "_TNAME - S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO") - ; - S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,17) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),19)=PID - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20) - S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20) - Q - ; -NOTA(PTIEN,PIEN) ; - ;PTIEN - patient team assignment (#404.42) - ;PIEN - patient ien - N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN - N ROLN,PCAP,PRCN,ADATE - S POS="[Not Assigned]",POSIEN=0 - S PNAME="[Not Assigned]",PNIEN=0 - S (ROLN,PCAP,PRCN,ADATE)="" - ; - S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name - S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") - ;S PID=$E(PID,6,10) ;9 digit ssn patch 526 - ; - S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien - S TMN=$G(^SCTM(404.51,TIEN,0)) - Q:TMN="" - S TNAME=$P(TMN,"^") ;team name - S PC=$P(TMN,"^",5) ;primary care team 1/0 - S IIEN=+$P(TMN,"^",7) ;institution ien - S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name - ; - D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN) - Q +SCRPTA2 ;ALB/CMM - Patient Listing w/Team Assignment Data ; 30 Jun 99 1:33 PM + ;;5.3;Scheduling;**41,88,140,148,174,181,177**;AUG 13, 1993 + ; + ;Patient Listing w/Team Assignment Data Report continued + ; +CHK(PTIEN,PIEN) ;assigned to a position + ;PTIEN - ien of 404.42 Patient Team Assignment file + ;PIEN - ien of patient file #2 + ; + N NODE,START,TPIEN,TPNODE,ROL,PRAC,ROLN,PCAP,PRCN + S START="" + Q:'$D(^SCPT(404.43,"B",PTIEN))&(PRACT'="") + I '$D(^SCPT(404.43,"B",PTIEN))&(PRACT="") D NOTA(PTIEN,PIEN) Q + F S START=$O(^SCPT(404.43,"B",PTIEN,START)) Q:START="" D + .S NODE=$G(^SCPT(404.43,START,0)) + .Q:NODE="" + .Q:($P(NODE,"^",4)'="")&($P(NODE,"^",4)0:" AP",1:"PCP") ; PC? + .S PRCN=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) ;preceptor name + .; + .S ROL=+$P(TPNODE,"^",3) ;role for position (ien) + .Q:'$D(ROLE(ROL))&(ROLE'=1) ;not a selected role + .S ROLN=$P($G(^SD(403.46,ROL,0)),U) ;role name + .; + .S PRAC=$$PRACI(TPIEN) ;practitioner information + .I +PRAC=-1 D NOTA(PTIEN,PIEN) Q + .I (PRACT'=1)&('$D(PRACT(+PRAC)))&(+PRAC'=0) Q + .; ^ not a selected practitioner + .; + .S POS=$P($G(^SCTM(404.57,TPIEN,0)),"^") + .D FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) + Q +PRACI(TPIEN) ; + ;TPIEN - team position ien (404.57) + ; + N EN,TPLIST,TPERR,NAME,POS,ERR,NPIEN,NODE,POSIEN + S TPLIST="TPLST",TPERR="ERR2" + K @TPLIST,@TPERR + S ERR=$$PRTP^SCAPMC8(TPIEN,,.TPLIST,.TPERR) + Q:ERR=0!($D(@TPERR)) -1 + S NODE=$G(@TPLIST@(1)) + Q:NODE="" "0^[Not Assigned]" + S NAME=$P(NODE,"^",2) ;practitioner name + S NPIEN=+$P(NODE,"^") ;practitioner ien + S POS=$P(NODE,"^",4) ;position name + S POSIEN=+$P(NODE,"^",3) ;position ien + I POS="" S POS="[Not Assigned]",POSIEN=0 + I NAME="" S NAME="[Not Assigned]",NPIEN=0 + K @TPLIST,@TPERR + Q NPIEN_"^"_NAME_"^"_POS_"^"_POSIEN + ; +FOUND2(START,NODE,TPIEN,POS,TPNODE,PRAC,PIEN,ROLN,PCAP,PRCN) ; + ;START - patient team assignment position ien + ;NODE - patient team position assignment node + ;TPIEN - team position ien (404.57) + ;POS - team position + ;TPNODE - team position node (404.57) + ;PRAC - practitioner info. NAME IEN^NAME^POS^POSIEN + ;ROLN - role name + ;PCAP - PC/AP/NPC assignment? + ;PRCN - preceptor name + ; + N PTNAME,PID,ADATE + S PTNAME=$P($G(^DPT(PIEN,0)),"^") ;patient name + S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") + S PID=$E(PID,6,10) ;last four pid include 5th for pseudo notation + ; + S ADATE=$P(NODE,"^",3) ;position assignment date - fm format + ;convert to external format + I ADATE'="" S ADATE=$TR($$FMTE^XLFDT(ADATE,"5DF")," ","0") + ; + S PNAME=$P(PRAC,"^",2) ;practitioner name + S PNIEN=$P(PRAC,"^") ;practitioner ien + ; + S TIEN=+$P(TPNODE,"^",2) ;ien team file 404.51 + S TMN=$G(^SCTM(404.51,TIEN,0)) + Q:TMN="" + S TNAME=$P(TMN,"^") ;team name + S PC=$P(TMN,"^",5) ;primary care team 1/0 + S IIEN=+$P(TMN,"^",7) ;institution ien + S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution + ; + D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,TPIEN,ADATE,PIEN,ROLN,PCAP,PRCN) + Q + ; +FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PIEN,POS,TPIEN,ADATE,PTIEN,ROLN,PCAP,PRCN) ; + ;IIEN - institution ien + ;INAME - institution name + ;TNAME - team name + ;TIEN - team ien + ;PC - primary care 1/0 + ;PTNAME - patient name + ;PID - last 4 pid plus 5th pseudo + ;PNAME - practitioner name + ;PIEN - practitioner ien + ;POS - position name + ;TPIEN - position ien + ;ADATE - assignment date + ;PTIEN - patient ien + ;ROLN - role name + ;PCAP - PC/AP/NPC assignment? + ;PRCN - preceptor name + ; + I INAME="" S INAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + I PNAME="" S PNAME="[BAD DATA]" + I '$D(@STORE@("I",INAME,IIEN)) S @STORE@("I",INAME,IIEN)="" + I '$D(@STORE@("T",IIEN,TNAME,TIEN)) S @STORE@("T",IIEN,TNAME,TIEN)="" + I '$D(@STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)) S @STORE@("P",IIEN,TIEN,PNAME,PIEN,TPIEN)="" + S @STORE@(IIEN)="Division: "_INAME + S @STORE@(IIEN,TIEN)="Team: "_TNAME + S $E(@STORE@(IIEN,TIEN),40)="Primary Care Team: "_$S(PC=1:"YES",1:"NO") + ; + S @STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN)=$E(PTNAME,1,21) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),24)=PID + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),31)=ADATE + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),43)=PCAP + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),49)=$E(PNAME,1,21) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),70)=$E(POS,1,20) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),92)=$E(ROLN,1,20) + S $E(@STORE@(IIEN,TIEN,PIEN,TPIEN,PTNAME,PTIEN),113)=$E(PRCN,1,20) + Q + ; +NOTA(PTIEN,PIEN) ; + ;PTIEN - patient team assignment (#404.42) + ;PIEN - patient ien + N IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POSIEN,POS,TPIEN + N ROLN,PCAP,PRCN,ADATE + S POS="[Not Assigned]",POSIEN=0 + S PNAME="[Not Assigned]",PNIEN=0 + S (ROLN,PCAP,PRCN,ADATE)="" + ; + S PTNAME=$E($P($G(^DPT(PIEN,0)),"^"),1,20) ;patient name + S PID=$P($G(^DPT(PIEN,.36)),"^",3),PID=$TR(PID,"-","") + S PID=$E(PID,6,10) ;last 4 plus 5th for psuedo + ; + S TIEN=+$P($G(^SCPT(404.42,PTIEN,0)),"^",3) ;team ien + S TMN=$G(^SCTM(404.51,TIEN,0)) + Q:TMN="" + S TNAME=$P(TMN,"^") ;team name + S PC=$P(TMN,"^",5) ;primary care team 1/0 + S IIEN=+$P(TMN,"^",7) ;institution ien + S INAME=$P($G(^DIC(4,IIEN,0)),"^") ;institution name + ; + D FORMAT(IIEN,INAME,TNAME,TIEN,PC,PTNAME,PID,PNAME,PNIEN,POS,POSIEN,ADATE,PIEN,ROLN,PCAP,PRCN) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM.m (revision 623) @@ -1,166 +1,163 @@ -SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,52,181,177,520**;AUG 13, 1993;Build 26 - ; - ;List of Team's Members Report - ; -PROMPTS ; - ;Prompt for Institution, Team, Date Range, User Class, Role - ;and Print device - ; - N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER - K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR - W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q - ; -QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;USERC - user classes selected (variable and array) - ;ROLE - roles selected (variable and array) - ;RANGE - date range selected (begin date ^ end date) - N ZTSAVE,II - F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ; - ;Second entry point for GUI to use - ;Input Parameters: - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;USERC - user classes selected (variable and array) - ;ROLE - roles selected (variable and array) - ;RANGE - date range selected (begin date ^ end date) - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q - ; - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPTM" - S ZTDESC="List of Team's Members",ZTIO=IOP - N II - F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ; - ;driver entry point - S TITL="Team Member Listing" - S STORE="^TMP("_$J_",""SCRPTM"")" - K @STORE - S @STORE=0 - D BUILD - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT(STORE,TITL) - D EXIT2 - Q - ; -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP - Q -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC - Q - ; -BUILD ;get report data - ;get all practitioners for all teams selected - I TEAM=1 D TALL ;all teams selected - N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST - S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2) - S SCDT("INCL")=0,SCDT="SCDT" - S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")" - F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D - .K XLIST,@PLIST - .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR") - .S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D - ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0) - ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q ;not a selected role - ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q ;not a selected user class - ..K YLIST - ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) - ..S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D - ...S @PLIST@(0)=$G(@PLIST@(0))+1 - ...S @PLIST@(@PLIST@(0))=YLIST(SCI) - ...Q - ..Q - .I OKAY D PULL^SCRPTM2(TIEN,.PLIST) - .Q - Q - ; -TALL ; - ;get all active team for divisions selected - N NXT,IIEN,NODE - S NXT=0,IIEN="" - ;$O through team file and find all active teams for selected divisions - F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D - .I INST=1!$D(INST(IIEN)) D - ..S TIEN=0 - ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D - ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" - Q - ; -PRINTIT(STORE,TITL) ; - N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS - S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF - D TITLE^SCRPU3(.PAGE,TITL) - F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D - .S INST=$O(@STORE@("I",EINST,"")) - .Q:INST="" - .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line - .S (ETEAM,TEM)="" - .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D - ..S TEM=$O(@STORE@("T",INST,ETEAM,0)) - ..I TEM="" Q - ..S NXT="H" - ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0 - ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0 - ..I STOP Q - ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) - ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) - ..I STOP Q - ..F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP) D - ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info - ..S (EPRACT,PRACT)="" - ..W ! ;extra line between members and practioner list - ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D - ...F S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP) D - ....I PRACT="" Q - ....S POS="" - ....F S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP) D - .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD) - .....W ! ;seperated positions - ....W ! ;separates practitioners - .S NPAGE=1 - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q - ; -PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; - ; - N CNT,SCAC - S CNT="" - I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) - I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) - I STOP Q - F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D - .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT)) - .S SCAC="" I CNT=4 D - ..F S SCAC=$O(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) Q:SCAC=""!(STOP) D - ...W !,$G(@STORE@(INST,TEM,PRACT,POS,4,SCAC)) - Q +SCRPTM ;ALB/CMM - List of Team's Members Report ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,52,181,177**;AUG 13, 1993 + ; + ;List of Team's Members Report + ; +PROMPTS ; + ;Prompt for Institution, Team, Date Range, User Class, Role + ;and Print device + ; + N VAUTD,VAUTT,VAUTUC,VAUTR,QTIME,RANG,PRNT,NUMBER + K VAUTD,VAUTT,VAUTUC,VAUTR,SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y S RANG=$$DTRANG^SCRPU2() I +RANG=-1 G ERR + W ! K Y D USER^SCRPU1 I '$D(VAUTUC)&($P($G(^SD(404.91,1,"PCMM")),"^")=1) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + D QUE(.VAUTD,.VAUTT,.VAUTUC,.VAUTR,RANG) Q + ; +QUE(INST,TEAM,USERC,ROLE,RANGE) ;queue report + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;USERC - user classes selected (variable and array) + ;ROLE - roles selected (variable and array) + ;RANGE - date range selected (begin date ^ end date) + N ZTSAVE,II + F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPTM","Team Member Listing",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,USERC,ROLE,RANGE,IOP,ZTDTH) ; + ;Second entry point for GUI to use + ;Input Parameters: + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;USERC - user classes selected (variable and array) + ;ROLE - roles selected (variable and array) + ;RANGE - date range selected (begin date ^ end date) + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(RANGE)!'$D(IOP)!(IOP="") Q + ; + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPTM" + S ZTDESC="List of Team's Members",ZTIO=IOP + N II + F II="INST","TEAM","USERC","ROLE","INST(","TEAM(","USERC(","ROLE(","RANGE","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ; + ;driver entry point + S TITL="Team Member Listing" + S STORE="^TMP("_$J_",""SCRPTM"")" + K @STORE + S @STORE=0 + D BUILD + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT(STORE,TITL) + D EXIT2 + Q + ; +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP + Q +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,NODATA,RANGE,ROLE,USERC + Q + ; +BUILD ;get report data + ;get all practitioners for all teams selected + I TEAM=1 D TALL ;all teams selected + N TIEN,OKAY,XLIST,YLIST,SCTP,SCI,SCDT,PLIST + S SCDT("BEGIN")=$P(RANGE,U),SCDT("END")=$P(RANGE,U,2) + S SCDT("INCL")=0,SCDT="SCDT" + S TIEN="",PLIST="^TMP(""SCRP"",$J,""LIST"")" + F S TIEN=$O(TEAM(TIEN)) Q:TIEN=""!(TIEN'?.N) D + .K XLIST,@PLIST + .S OKAY=$$TPTM^SCAPMC(TIEN,.SCDT,"","","XLIST","ERROR") + .S SCTP=0 F S SCTP=$O(XLIST("SCTP",TIEN,SCTP)) Q:'SCTP D + ..S SCTP0=$G(^SCTM(404.57,SCTP,0)) Q:'$L(SCTP0) + ..I ROLE'=1,'$D(ROLE(+$P(SCTP0,U,3))) Q ;not a selected role + ..I $D(USERC),USERC'=1,'$D(USERC(+$P(SCTP0,U,13))) Q ;not a selected user class + ..K YLIST + ..S OKAY=$$PRTP^SCAPMC(SCTP,.SCDT,"YLIST","ERROR",1,0) + ..S SCI=0 F S SCI=$O(YLIST(SCI)) Q:'SCI D + ...S @PLIST@(0)=$G(@PLIST@(0))+1 + ...S @PLIST@(@PLIST@(0))=YLIST(SCI) + ...Q + ..Q + .I OKAY D PULL^SCRPTM2(TIEN,.PLIST) + .Q + Q + ; +TALL ; + ;get all active team for divisions selected + N NXT,IIEN,NODE + S NXT=0,IIEN="" + ;$O through team file and find all active teams for selected divisions + F S IIEN=$O(^SCTM(404.51,"AINST",IIEN)) Q:IIEN="" D + .I INST=1!$D(INST(IIEN)) D + ..S TIEN=0 + ..F S TIEN=$O(^SCTM(404.51,"AINST",IIEN,TIEN)) Q:TIEN="" D + ...I $$ACTTM^SCMCTMU(TIEN) S TEAM(TIEN)="" + Q + ; +PRINTIT(STORE,TITL) ; + N INST,EINST,ETEAM,TEM,EPRACT,PRACT,PAGE,NXT,NPAGE,CNT,HEAD,POS + S EINST="",(NPAGE,STOP,HEAD)=0,PAGE=1 W:$E(IOST)="C" @IOF + D TITLE^SCRPU3(.PAGE,TITL) + F S EINST=$O(@STORE@("I",EINST)) Q:EINST=""!(STOP) D + .S INST=$O(@STORE@("I",EINST,"")) + .Q:INST="" + .I 'NPAGE W !,$G(@STORE@(INST)) ;write institution line + .S (ETEAM,TEM)="" + .F S ETEAM=$O(@STORE@("T",INST,ETEAM)) Q:ETEAM=""!(STOP) D + ..S TEM=$O(@STORE@("T",INST,ETEAM,0)) + ..I TEM="" Q + ..S NXT="H" + ..I NPAGE,(IOST'?1"C-".E) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) S NPAGE=0 + ..I NPAGE,(IOST?1"C-".E) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) S NPAGE=0 + ..I STOP Q + ..I IOST'?1"C-".E,$Y>(IOSL-5) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) + ..I IOST?1"C-".E,$Y>(IOSL-5) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) + ..I STOP Q + ..F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E!(STOP) D + ...I 'HEAD W !,$G(@STORE@(INST,TEM,NXT)) S HEAD=0 ;writes team info + ..S (EPRACT,PRACT)="" + ..W ! ;extra line between members and practioner list + ..F S EPRACT=$O(@STORE@("PN",INST,TEM,EPRACT)) Q:EPRACT=""!(STOP) D + ...F S PRACT=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT)) Q:PRACT=""!(STOP) D + ....I PRACT="" Q + ....S POS="" + ....F S POS=$O(@STORE@("PN",INST,TEM,EPRACT,PRACT,POS)) Q:POS=""!(STOP) D + .....D PRNTD(INST,TEM,PRACT,POS,TITL,.PAGE,.HEAD) + .....W ! ;seperated positions + ....W ! ;separates practitioners + .S NPAGE=1 + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q + ; +PRNTD(INST,TEM,PRACT,POS,TITL,PAGE,HEAD) ; + ; + N CNT + S CNT="" + I IOST'?1"C-".E,$Y>(IOSL-11) D NEWP^SCRPTM2(INST,TEM,TITL,.PAGE,.HEAD) + I IOST?1"C-".E,$Y>(IOSL-11) D HOLD1^SCRPTM2(.PAGE,TITL,INST,TEM,.HEAD) + I STOP Q + F S CNT=$O(@STORE@(INST,TEM,PRACT,POS,CNT)) Q:CNT=""!(STOP) D + .W !,$G(@STORE@(INST,TEM,PRACT,POS,CNT)) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTM2.m (revision 623) @@ -1,137 +1,128 @@ -SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,140,177,520**;AUG 13, 1993;Build 26 - ; - ;List of Team's Members Report - ; -PULL(TIEN,PLIST) ; - ;TIEN - team file ien - ;PLIST - array of positions and their practitioners - ; - N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI - N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS - ; - S CNT=0 - F S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N) D - .;get each practitioner/position - .S NODE=$G(@PLIST@(CNT)) - .S TPIEN=+$P(NODE,"^",3) ;team position ien - .S PNAME=$P(NODE,"^",4) ;position name - .S ACT=$P(NODE,"^",9) ;active date (fm) - .I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0") - .S INACT=$P(NODE,"^",10) ;inactive date (fm) - .I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0") - .S RNAME=$P(NODE,"^",8) ;standard role name - .S UNAME=$P(NODE,"^",6) ;user class name - .S PRIEN=+$P(NODE,"^") ;practitioner ien - .S PRNAME=$P(NODE,"^",2) ;practitioner name - .; - .;Get person class information - .S PCLASS=$$GET^XUA4A72(PRIEN) - .F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) - .; - .S TPNODE=$G(^SCTM(404.57,+TPIEN,0)) - .D SETASCL^SCRPRAC2(TPIEN,.PCLIN) - .S PCLIN=$G(PCLIN(0)) - .;S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien - .;S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name - .; - .;Get preceptor - .S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) - .; - .S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node - .S TNAME=$P(TNODE,"^") ;team name - .S TPHONE=$P(TNODE,"^",2) ;team phone - .S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care? - .S INS=+$P(TNODE,"^",7) ;team division ien - .S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name - .D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS) - .; - .S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone - .S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room - .S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien - .S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name - .; - .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS) - .N SCAC - .S SCAC=0 - .F S SCAC=$O(PCLIN(SCAC)) Q:SCAC="" D FORMATAC(INS,TIEN,PRIEN,TPIEN,PCLIN(SCAC)) - Q - ; -KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ; - ;store team information - I TDIV="" S TDIV="[BAD DATA]" - I TNAME="" S TNAME="[BDA DATA]" - S @STORE@("I",TDIV,IEND)="" - S @STORE@("T",IEND,TNAME,TIEN)="" - S @STORE@(IEND)="Division: "_TDIV - S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME - S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE - S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC - S @STORE@(IEND,TIEN,"H3")="" - S @STORE@(IEND,TIEN,"H4")="Members:" - Q - ; -FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ; - ;POS - position name - ;TPIEN - position ien - ;PCLIN - associated clinic - ;SPOS - standard position - ;UCLASS - user class - ;BEG - begin date - ;END - end date - ;PIEN - ien of new person file - ;PRACT - practitioner name - ;OPH - office number - ;ROOM - room - ;SERV - service - ;DIV - ien of division - ;TEM - ien of team - ;PRCP - preceptor - ;PCLASS - person class - ; - N SCI - I PRACT="" S PRACT="[BAD DATA]" - S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)="" - S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS - S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS - S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS - S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN - S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM - S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END - S SCI=7 - I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8 - I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1 - I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(2),SCI=SCI+1 - I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(3) - Q - ; -FORMATAC(DIV,TEM,PIEN,TPIEN,PCLIN) ; - S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4,SCAC),49)=$E(PCLIN,1,30) - Q - ; -NEWP(INST,TEM,TITL,PAGE,HEAD) ; - ;new page - D NEWP1^SCRPU3(.PAGE,TITL) - D HEAD1(INST,TEM,.HEAD) - Q - ; -HEAD1(INST,TEM,HEAD) ; - ;write headings - W !,$G(@STORE@(INST)) - N NXT - S NXT="H" - F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E D - .W !,$G(@STORE@(INST,TEM,NXT)) - W ! ;extra line between MEMBERS and practitioner list - S HEAD=1 - Q -HOLD1(PAGE,TITL,INST,TEM,HEAD) ; - ;device is home, reached end of page - D HOLD^SCRPU3(.PAGE,TITL) - I STOP Q - D HEAD1(INST,TEM,.HEAD) - Q +SCRPTM2 ;ALB/CMM - List of Team's Members Report Continued;01/29/96 ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,140,177**;AUG 13, 1993 + ; + ;List of Team's Members Report + ; +PULL(TIEN,PLIST) ; + ;TIEN - team file ien + ;PLIST - array of positions and their practitioners + ; + N PNAME,TPIEN,ACT,INACT,RNAME,UNAME,CNT,NODE,TNODE,PCLIN,TNAME,SCI + N TPHONE,TPC,INS,INAME,PRIEN,PRNAME,OPH,ROOM,SERV,TPNODE,PRCP,PCLASS + ; + S CNT=0 + F S CNT=$O(@PLIST@(CNT)) Q:CNT=""!(CNT'?.N) D + .;get each practitioner/position + .S NODE=$G(@PLIST@(CNT)) + .S TPIEN=+$P(NODE,"^",3) ;team position ien + .S PNAME=$P(NODE,"^",4) ;position name + .S ACT=$P(NODE,"^",9) ;active date (fm) + .I ACT'=""&(ACT'=0) S ACT=$TR($$FMTE^XLFDT(ACT,"5DF")," ","0") + .S INACT=$P(NODE,"^",10) ;inactive date (fm) + .I INACT'=""&(INACT'=0) S INACT=$TR($$FMTE^XLFDT(INACT,"5DF")," ","0") + .S RNAME=$P(NODE,"^",8) ;standard role name + .S UNAME=$P(NODE,"^",6) ;user class name + .S PRIEN=+$P(NODE,"^") ;practitioner ien + .S PRNAME=$P(NODE,"^",2) ;practitioner name + .; + .;Get person class information + .S PCLASS=$$GET^XUA4A72(PRIEN) + .F SCI=1,2,3 S PCLASS(SCI)=$P(PCLASS,U,(SCI+1)) + .; + .S TPNODE=$G(^SCTM(404.57,+TPIEN,0)) + .S PCLIN=+$P(TPNODE,"^",9) ;associated clinic ien + .S PCLIN=$P($G(^SC(PCLIN,0)),"^") ;associated clinic name + .; + .;Get preceptor + .S PRCP=$P($$OKPREC2^SCMCLK(TPIEN,DT),U,2) + .; + .S TNODE=$G(^SCTM(404.51,TIEN,0)) ;team node + .S TNAME=$P(TNODE,"^") ;team name + .S TPHONE=$P(TNODE,"^",2) ;team phone + .S TPC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care? + .S INS=+$P(TNODE,"^",7) ;team division ien + .S INAME=$P($G(^DIC(4,INS,0)),"^") ;team division name + .D KTEAM(TNAME,TPHONE,TPC,INAME,TIEN,INS) + .; + .S OPH=$P($G(^VA(200,PRIEN,.13)),"^",2) ;office phone + .S ROOM=$P($G(^VA(200,PRIEN,.14)),"^") ;room + .S SERV=+$P($G(^VA(200,PRIEN,5)),"^") ;service/section ien + .S SERV=$P($G(^DIC(49,SERV,0)),"^") ;service/section name + .; + .D FORMAT(PNAME,TPIEN,PCLIN,RNAME,UNAME,ACT,INACT,PRIEN,PRNAME,OPH,ROOM,SERV,INS,TIEN,PRCP,.PCLASS) + Q + ; +KTEAM(TNAME,TPHONE,TPC,TDIV,TIEN,IEND) ; + ;store team information + I TDIV="" S TDIV="[BAD DATA]" + I TNAME="" S TNAME="[BDA DATA]" + S @STORE@("I",TDIV,IEND)="" + S @STORE@("T",IEND,TNAME,TIEN)="" + S @STORE@(IEND)="Division: "_TDIV + S @STORE@(IEND,TIEN,"H1")="Team Name: "_TNAME + S $E(@STORE@(IEND,TIEN,"H1"),40)="Team Phone: "_TPHONE + S @STORE@(IEND,TIEN,"H2")="Primary Care Team: "_TPC + S @STORE@(IEND,TIEN,"H3")="" + S @STORE@(IEND,TIEN,"H4")="Members:" + Q + ; +FORMAT(POS,TPIEN,PCLIN,SPOS,UCLASS,BEG,END,PIEN,PRACT,OPH,ROOM,SERV,DIV,TEM,PRCP,PCLASS) ; + ;POS - position name + ;TPIEN - position ien + ;PCLIN - associated clinic + ;SPOS - standard position + ;UCLASS - user class + ;BEG - begin date + ;END - end date + ;PIEN - ien of new person file + ;PRACT - practitioner name + ;OPH - office number + ;ROOM - room + ;SERV - service + ;DIV - ien of division + ;TEM - ien of team + ;PRCP - preceptor + ;PCLASS - person class + ; + N SCI + I PRACT="" S PRACT="[BAD DATA]" + S @STORE@("PN",DIV,TEM,PRACT,PIEN,TPIEN)="" + S @STORE@(DIV,TEM,PIEN,TPIEN,1)=PRACT + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,1),35)="Position: "_POS + S @STORE@(DIV,TEM,PIEN,TPIEN,2)="Standard Role: "_SPOS + S @STORE@(DIV,TEM,PIEN,TPIEN,3)="User Class: "_UCLASS + S @STORE@(DIV,TEM,PIEN,TPIEN,4)=SERV + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,4),35)="Assoc Clinic: "_PCLIN + S @STORE@(DIV,TEM,PIEN,TPIEN,5)="Office Phone: "_OPH + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,5),35)="Room: "_ROOM + S @STORE@(DIV,TEM,PIEN,TPIEN,6)="Begin Date: "_BEG + S $E(@STORE@(DIV,TEM,PIEN,TPIEN,6),35)="End Date: "_END + S SCI=7 + I $L(PRCP) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Preceptor: "_PRCP,SCI=8 + I $L(PCLASS(1)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)="Person Class: "_PCLASS(1),SCI=SCI+1 + I $L(PCLASS(2)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(2),SCI=SCI+1 + I $L(PCLASS(3)) S @STORE@(DIV,TEM,PIEN,TPIEN,SCI)=" "_PCLASS(3) + Q + ; +NEWP(INST,TEM,TITL,PAGE,HEAD) ; + ;new page + D NEWP1^SCRPU3(.PAGE,TITL) + D HEAD1(INST,TEM,.HEAD) + Q + ; +HEAD1(INST,TEM,HEAD) ; + ;write headings + W !,$G(@STORE@(INST)) + N NXT + S NXT="H" + F S NXT=$O(@STORE@(INST,TEM,NXT)) Q:NXT'?1"H".E D + .W !,$G(@STORE@(INST,TEM,NXT)) + W ! ;extra line between MEMBERS and practitioner list + S HEAD=1 + Q +HOLD1(PAGE,TITL,INST,TEM,HEAD) ; + ;device is home, reached end of page + D HOLD^SCRPU3(.PAGE,TITL) + I STOP Q + D HEAD1(INST,TEM,.HEAD) + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP.m (revision 623) @@ -1,177 +1,148 @@ -SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,174,177,526,520**;AUG 13, 1993;Build 26 - ; -PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device - N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER - K SCUP - S QTIME="" - W ! D INST^SCRPU1 I Y=-1 G ERR - W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR - W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR - W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR - W ! K Y S SORT=$$SORT2^SCRPU2() - I SORT<1 G ERR - W !!,"This report requires 132 column output!" - D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q - ; -QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PSTAT - patient status - 1=all or OPT or AC - ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID - N ZTSAVE,II - F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)="" - W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE) - Q - ; -ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use - ;INST - institutions selected (variable and array) - ;TEAM - teams selected (variable and array) - ;ROLE - roles selected (variable and array) - ;PSTAT - patient status - 1=all or OPT or AC - ;SORT - 1=d,t,ptname 2=d,t,Pt ID 3=d,t,pract,pt name 4=d,t,pract,Pt ID - ;IOP - print device - ;ZTDTH - queue time (optional) - ; - ;validate parameters - I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q - N NUMBER - S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") - I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) - I IOST?1"C-".E D QENTRY G RET - I ZTDTH="" S ZTDTH=$H - S ZTRTN="QENTRY^SCRPTP" - S ZTDESC="List of Team's Patients",ZTIO=IOP - N II - F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)="" - D ^%ZTLOAD -RET S NUMBER=0 - I $D(ZTSK) S NUMBER=ZTSK - D EXIT1 - Q NUMBER - ; -QENTRY ;driver entry point - S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")" - K @STORE - S @STORE=0 - D FIND - I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) - I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL) - D EXIT2 - Q -ERR ; -EXIT1 ; - K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP - Q -EXIT2 ; - K @STORE - K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA - Q -FIND ; - N TIEN,ERR,LIST,OKAY - I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected - S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR" - K @LIST,@ERR - F S TIEN=$O(TEAM(TIEN)) Q:TIEN="" D - .;TIEN - team ien - .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR) - .; gets all patients for given team - .D HITS^SCRPTP3(LIST,TIEN) - .K @LIST,@ERR - K @LIST,@ERR - Q -TINF(TIEN) ;team information - ;TIEN - team ien - ;returns: institution ien ^ team name ^ primary care ^ team phone - N PC,PHONE,TNODE,TNAME - S TNODE=$G(^SCTM(404.51,TIEN,0)) - S TNAME=$P(TNODE,"^") ;team name - S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team - S PHONE=$P(TNODE,"^",2) ;team phone - S INS=+$P(TNODE,"^",7) ;institution ien - D TDESC^SCRPITP2(TIEN,INS) ;gets team description - Q INS_"^"_TNAME_"^"_PC_"^"_PHONE - ; -PST(PTIEN,CLIEN) ; - ;PTIEN - patient ien - ;CLIEN - associated clinic ien - ;returns 1=selected patient status, 0=not selected patient status - ; - N EN,NXT,FOUND,ENODE - S EN="",(FOUND,NXT)=0 - Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND - S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) - I EN=""&(PSTAT=1) S FOUND=1 Q FOUND - Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND - F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D - .;check if active enrollment - .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) - .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment - .; ^ discharge date ^ enrollment date - .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1) ;not selected patient status - .S FOUND=1 - Q FOUND - ; -FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) ;Format column information - ;INS - Institution ien - ;TIEN - team ien - ;PTIEN - patient ien - ;PTNAME - patient name - ;PID - SSN - ;PIEN - practitioner ien - ;PNAME - practitioner name - ;CNAME - clinic name - ;LAST - last appointment - ;NEXT - next appointment - ;ROLN - role name - ;PCAP - PC? - ; - N SEC,TRD - I PNAME="" S PNAME="[BAD DATA]" - I PTNAME="" S PTNAME="[BAD DATA]" - I PID="" S PID="*********" - S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner - S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient - S @STORE@("PID",INS,TIEN,PID,PTIEN)="" - I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner - I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner - S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,15) ;patient name - S $E(@STORE@(INS,TIEN,SEC,TRD),18)=PID ;9 digit pid - S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name - S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name - S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC? - S $E(@STORE@(INS,TIEN,SEC,TRD),85)=$P(PINF,"^",8) ;last appointment - S $E(@STORE@(INS,TIEN,SEC,TRD),97)=$P(PINF,"^",9) ;next appointment - S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name - Q -FORMATAC(SCCNT,CNAME,PINF,INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) ;Format MULTIPLES - ;INS - Institution ien - ;TIEN - team ien - ;PTIEN - patient ien - ;PTNAME - patient name - ;PID - last 4 PID - includes pseudo notation as 5th - ;PIEN - practitioner ien - ;PNAME - practitioner name - ;CNAME - clinic name - ;LAST - last appointment - ;NEXT - next appointment - ;ROLN - role name - ;PCAP - PC? - ; - N SEC,TRD - I PNAME="" S PNAME="[BAD DATA]" - I PTNAME="" S PTNAME="[BAD DATA]" - I PID="" S PID="****" - S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner - S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient - S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid - N TRD - I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner - I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner - I '$D(@STORE@(INS,TIEN,SEC,TRD,SCCNT)) D - .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),85)=$P(PINF,"^",8) ;last appointment - .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),97)=$P(PINF,"^",9) ;next appointment - .S $E(@STORE@(INS,TIEN,SEC,TRD,SCCNT),109)=$E(CNAME,1,24) ;clinic name - .Q - Q +SCRPTP ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,174,177**;AUG 13, 1993 + ; +PROMPTS ;Prompt for Institution, Team, Role, Patient Status and Print device + N QTIME,PRNT,VAUTD,VAUTT,VAUTR,VAUTPS,NUMBER + K SCUP + S QTIME="" + W ! D INST^SCRPU1 I Y=-1 G ERR + W ! K Y D PRMTT^SCRPU1 I '$D(VAUTT) G ERR + W ! K Y D ROLE^SCRPU1 I '$D(VAUTR) G ERR + W ! K Y D PTSTAT^SCRPU2 I '$D(VAUTPS) G ERR + W ! K Y S SORT=$$SORT2^SCRPU2() + I SORT<1 G ERR + W !!,"This report requires 132 column output!" + D QUE(.VAUTD,.VAUTT,.VAUTR,VAUTPS,SORT) Q + ; +QUE(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;queue report + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PSTAT - patient status - 1=all or OPT or AC + ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID + N ZTSAVE,II + F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(" S ZTSAVE(II)="" + W ! D EN^XUTMDEVQ("QENTRY^SCRPTP","Team Patient Listing",.ZTSAVE) + Q + ; +ENTRY2(INST,TEAM,ROLE,PSTAT,SORT,IOP,ZTDTH) ;Second entry point for GUI to use + ;INST - institutions selected (variable and array) + ;TEAM - teams selected (variable and array) + ;ROLE - roles selected (variable and array) + ;PSTAT - patient status - 1=all or OPT or AC + ;SORT - 1=d,t,ptname 2=d,t,last 4 Pt ID 3=d,t,pract,pt name 4=d,t,pract,last 4 Pt ID + ;IOP - print device + ;ZTDTH - queue time (optional) + ; + ;validate parameters + I '$D(INST)!'$D(TEAM)!'$D(ROLE)!'$D(PSTAT)!'$D(SORT)!'$D(IOP)!(IOP="") Q + N NUMBER + S IOST=$P(IOP,"^",2),IOP=$P(IOP,"^") + I IOP?1"Q;".E S IOP=$P(IOP,"Q;",2) + I IOST?1"C-".E D QENTRY G RET + I ZTDTH="" S ZTDTH=$H + S ZTRTN="QENTRY^SCRPTP" + S ZTDESC="List of Team's Patients",ZTIO=IOP + N II + F II="INST","TEAM","ROLE","ROLE(","SORT","PSTAT","INST(","TEAM(","IOP" S ZTSAVE(II)="" + D ^%ZTLOAD +RET S NUMBER=0 + I $D(ZTSK) S NUMBER=ZTSK + D EXIT1 + Q NUMBER + ; +QENTRY ;driver entry point + S TITL="Team Patient Listing",STORE="^TMP("_$J_",""SCRPTP"")" + K @STORE + S @STORE=0 + D FIND + I $O(@STORE@(0))="" S NODATA=$$NODATA^SCRPU3(TITL) + I '$D(NODATA) D PRINTIT^SCRPTP2(STORE,TITL) + D EXIT2 + Q +ERR ; +EXIT1 ; + K ZTDTH,ZTRTN,ZTDESC,ZTSK,ZTIO,ZTSAVE,SCUP + Q +EXIT2 ; + K @STORE + K STOP,STORE,TITL,IOP,TEAM,INST,ROLE,PSTAT,SORT,NODATA + Q +FIND ; + N TIEN,ERR,LIST,OKAY + I TEAM=1 D TALL^SCRPPAT3 ;gets all teams for all divisions selected + S TIEN="",LIST="^TMP("_$J_",""SCRPTP ARRAY"")",ERR="ERROR" + K @LIST,@ERR + F S TIEN=$O(TEAM(TIEN)) Q:TIEN="" D + .;TIEN - team ien + .S OKAY=$$PTTM^SCAPMC2(TIEN,"",LIST,ERR) + .; gets all patients for given team + .D HITS^SCRPTP3(LIST,TIEN) + .K @LIST,@ERR + K @LIST,@ERR + Q +TINF(TIEN) ;team information + ;TIEN - team ien + ;returns: institution ien ^ team name ^ primary care ^ team phone + N PC,PHONE,TNODE,TNAME + S TNODE=$G(^SCTM(404.51,TIEN,0)) + S TNAME=$P(TNODE,"^") ;team name + S PC=$S($P(TNODE,"^",5)=1:"YES",1:"NO") ;primary care team + S PHONE=$P(TNODE,"^",2) ;team phone + S INS=+$P(TNODE,"^",7) ;institution ien + D TDESC^SCRPITP2(TIEN,INS) ;gets team description + Q INS_"^"_TNAME_"^"_PC_"^"_PHONE + ; +PST(PTIEN,CLIEN) ; + ;PTIEN - patient ien + ;CLIEN - associated clinic ien + ;returns 1=selected patient status, 0=not selected patient status + ; + N EN,NXT,FOUND,ENODE + S EN="",(FOUND,NXT)=0 + Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND + S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) + I EN=""&(PSTAT=1) S FOUND=1 Q FOUND + Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND + F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D + .;check if active enrollment + .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) + .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment + .; ^ discharge date ^ enrollment date + .Q:$P(ENODE,"^",2)'=$E(PSTAT,1)&(PSTAT'=1) ;not selected patient status + .S FOUND=1 + Q FOUND + ; +FORMAT(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) ;Format column information + ;INS - Institution ien + ;TIEN - team ien + ;PTIEN - patient ien + ;PTNAME - patient name + ;PID - last 4 PID - includes pseudo notation as 5th + ;PIEN - practitioner ien + ;PNAME - practitioner name + ;CNAME - clinic name + ;LAST - last appointment + ;NEXT - next appointment + ;ROLN - role name + ;PCAP - PC? + ; + N SEC,TRD + I PNAME="" S PNAME="[BAD DATA]" + I PTNAME="" S PTNAME="[BAD DATA]" + I PID="" S PID="****" + S @STORE@("P",INS,TIEN,PNAME,PIEN)="" ;practitioner + S @STORE@("PT",INS,TIEN,PTNAME,PTIEN)="" ;patient + S @STORE@("PID",INS,TIEN,PID,PTIEN)="" ;last 4 pid + N TRD + I (SORT=1)!(SORT=2) S SEC=PTIEN,TRD=PIEN ;sort doesn't include practitioner + I (SORT=3)!(SORT=4) S SEC=PIEN,TRD=PTIEN ;sort includes practitioner + S @STORE@(INS,TIEN,SEC,TRD)=$E(PTNAME,1,22) ;patient name + S $E(@STORE@(INS,TIEN,SEC,TRD),25)=PID ;last 4 pid + S $E(@STORE@(INS,TIEN,SEC,TRD),32)=$E(PNAME,1,22) ;practitioner name + S $E(@STORE@(INS,TIEN,SEC,TRD),56)=$E($G(ROLN),1,22) ;role name + S $E(@STORE@(INS,TIEN,SEC,TRD),80)=$G(PCAP) ;PC? + S $E(@STORE@(INS,TIEN,SEC,TRD),85)=LAST ;last appointment + S $E(@STORE@(INS,TIEN,SEC,TRD),97)=NEXT ;next appointment + S $E(@STORE@(INS,TIEN,SEC,TRD),109)=$E(CNAME,1,24) ;clinic name + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP2.m (revision 623) @@ -1,149 +1,143 @@ -SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,53,52,174,177,231,526,520**;AUG 13, 1993;Build 26 - ; - ;List of Team's Patients Report - ; -TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information - ;INST - institution ien - ;INAME - institution name - ;TIEN - team ien - ;TNAME - team name - ;PHONE - team phone - ;PC - primary care team (yes/no) - ; - I INAME="" S INAME="[BAD DATA]" - I TNAME="" S TNAME="[BAD DATA]" - S @STORE@("I",INAME,INST)="" - S @STORE@("T",INST,TNAME,TIEN)="" - S @STORE@(INST)="Division: "_INAME - S @STORE@(INST,TIEN)="Team: "_TNAME - S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE - S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC - Q - ; -PRINTIT(STORE,TITL) ; - N INST,INAME,TNAME,TIEN - S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF - D TITLE^SCRPU3(.PAGE,TITL,132) ;write title - D SETH - ; - S INAME="" - F S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP) D - .S INST=$O(@STORE@("I",INAME,"")) - .Q:INST="" - .I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132) - .I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132) - .Q:STOP - .W !,$G(@STORE@(INST)) ;write institution - .S TNAME="" - .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D - ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) - ..Q:TIEN="" - ..D TPRINT(INST,TIEN) ;writes team info - ..Q:STOP - ..; - ..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) - ..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) - ..Q:STOP - ..D HEADER - ..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW) - ..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW) - K NEW,PAGE - I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR - Q - ; -PRACT(INST,TIEN,NEW) ;Print by practitioner/patient - N PNAME,PIEN,SEC2,ST1,TRD,TRDI - S PNAME="",PIEN="" - F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP) D - . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D - . . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name - . . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID - . . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" - . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . S (TRDI,TRD)="" - . . F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D - . . . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D - . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data - . . . . N SCACL - . . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) Q:SCACL="" D - . . . . . W !,$G(@STORE@(INST,TIEN,PIEN,TRDI,SCACL)) - . S NEW=0 - Q - ; -PTP(INST,TIEN,NEW) ;Print by patient/practitioner - N SEC2,ST1,TRDI,TRD,PNAME,PIEN - I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name - I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID - S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" - I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) - I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) - Q:STOP - S (TRDI,TRD)="" - F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D - . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D - . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . Q:STOP - . . S PNAME="",PIEN="" - . . F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0) D - . . . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D - . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER - . . . . Q:STOP - . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data - . . . . N SCACL - . . . . S SCACL="" F S SCACL=$O(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) Q:SCACL="" D - . . . . . W !,$G(@STORE@(INST,TIEN,TRDI,PIEN,SCACL)) - . S NEW=0 - Q - ; -TPRINT(INST,TIEN) ; - ;prints team data - N NXT - I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - Q:STOP - W !!,$G(@STORE@(INST,TIEN)) - S NXT=0 - W !,$G(@STORE@(INST,TIEN,1)) ;write team info - Q:'$D(@STORE@(INST,TIEN,"D")) W ! - S NXT="" - ;write team description - F S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP) D - .I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - .I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) - .Q:STOP - .W !,$G(@STORE@(INST,TIEN,"D",NXT)) - W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider" - W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider" - Q - ; -HEADER ;prints column headings - N NXT - F NXT="H1","H2","H3" D - .W !,$G(@STORE@(NXT)) - Q - ; -SETH ;sets column headings - S @STORE@("H2")="Patient Name" - S $E(@STORE@("H2"),18)="Pt ID" - S $E(@STORE@("H2"),32)="Practitioner" - S $E(@STORE@("H2"),56)="Role" - S $E(@STORE@("H2"),80)="PC?" - S $E(@STORE@("H1"),85)="Last" - S $E(@STORE@("H2"),85)="Appt." - S $E(@STORE@("H1"),97)="Next" - S $E(@STORE@("H2"),97)="Appt." - S $E(@STORE@("H2"),109)="Associated Clinic" - S $P(@STORE@("H3"),"=",133)="" - Q +SCRPTP2 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,53,52,174,177,231**;AUG 13, 1993 + ; + ;List of Team's Patients Report + ; +TFORMAT(INST,INAME,TIEN,TNAME,PHONE,PC) ; Format team information + ;INST - institution ien + ;INAME - institution name + ;TIEN - team ien + ;TNAME - team name + ;PHONE - team phone + ;PC - primary care team (yes/no) + ; + I INAME="" S INAME="[BAD DATA]" + I TNAME="" S TNAME="[BAD DATA]" + S @STORE@("I",INAME,INST)="" + S @STORE@("T",INST,TNAME,TIEN)="" + S @STORE@(INST)="Division: "_INAME + S @STORE@(INST,TIEN)="Team: "_TNAME + S $E(@STORE@(INST,TIEN),45)="Team Phone: "_PHONE + S @STORE@(INST,TIEN,1)="Primary Care Team: "_PC + Q + ; +PRINTIT(STORE,TITL) ; + N INST,INAME,TNAME,TIEN + S (NEW,PAGE)=1,STOP=0 W:$E(IOST)="C" @IOF + D TITLE^SCRPU3(.PAGE,TITL,132) ;write title + D SETH + ; + S INAME="" + F S INAME=$O(@STORE@("I",INAME)) Q:INAME=""!(STOP) D + .S INST=$O(@STORE@("I",INAME,"")) + .Q:INST="" + .I ('NEW)&(IOST'?1"C-".E) D NEWP1^SCRPU3(.PAGE,TITL,132) + .I ('NEW)&(IOST?1"C-".E) D HOLD^SCRPU3(.PAGE,TITL,132) + .Q:STOP + .W !,$G(@STORE@(INST)) ;write institution + .S TNAME="" + .F S TNAME=$O(@STORE@("T",INST,TNAME)) Q:TNAME=""!(STOP) D + ..S TIEN=$O(@STORE@("T",INST,TNAME,"")) + ..Q:TIEN="" + ..D TPRINT(INST,TIEN) ;writes team info + ..Q:STOP + ..; + ..I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) + ..I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) + ..Q:STOP + ..D HEADER + ..I (SORT=3)!(SORT=4) D PRACT(INST,TIEN,.NEW) + ..I (SORT=1)!(SORT=2) D PTP(INST,TIEN,.NEW) + K NEW,PAGE + I 'STOP,$E(IOST)="C" N DIR S DIR(0)="E" W ! D ^DIR + Q + ; +PRACT(INST,TIEN,NEW) ;Print by practitioner/patient + N PNAME,PIEN,SEC2,ST1,TRD,TRDI + S PNAME="",PIEN="" + F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP) D + . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D + . . I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name + . . I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID + . . S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" + . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . S (TRDI,TRD)="" + . . F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D + . . . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D + . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I $D(@STORE@(INST,TIEN,PIEN,TRDI)) W !,$G(@STORE@(INST,TIEN,PIEN,TRDI)) ;write column data + . S NEW=0 + Q + ; +PTP(INST,TIEN,NEW) ;Print by patient/practitioner + N SEC2,ST1,TRDI,TRD,PNAME,PIEN + I (SORT=1)!(SORT=3) S SEC2="""PT""" ;sort by patient name + I (SORT=2)!(SORT=4) S SEC2="""PID""" ;sort by last 4 PID + S ST1=$E(STORE,1,$L(STORE)-1)_","_SEC2_")" + I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) + I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) + Q:STOP + S (TRDI,TRD)="" + F S TRD=$O(@ST1@(INST,TIEN,TRD)) Q:TRD=""!(STOP) D + . F S TRDI=$O(@ST1@(INST,TIEN,TRD,TRDI)) Q:TRDI=""!(STOP) D + . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . Q:STOP + . . S PNAME="",PIEN="" + . . F S PNAME=$O(@STORE@("P",INST,TIEN,PNAME)) Q:PNAME=""!(STOP)!(PIEN=0) D + . . . F S PIEN=$O(@STORE@("P",INST,TIEN,PNAME,PIEN)) Q:PIEN=""!(STOP) D + . . . . I (IOST'?1"C-".E)&($Y>(IOSL-4)) D NEWP1^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I (IOST?1"C-".E)&($Y>(IOSL-4)) D HOLD^SCRPU3(.PAGE,TITL,132) D:'STOP HEADER + . . . . Q:STOP + . . . . I $D(@STORE@(INST,TIEN,TRDI,PIEN)) W !,$G(@STORE@(INST,TIEN,TRDI,PIEN)) ;write column data + . S NEW=0 + Q + ; +TPRINT(INST,TIEN) ; + ;prints team data + N NXT + I (IOST'?1"C-".E)&($Y>(IOSL-13)) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + I (IOST?1"C-".E)&($Y>(IOSL-13)) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + Q:STOP + W !!,$G(@STORE@(INST,TIEN)) + S NXT=0 + W !,$G(@STORE@(INST,TIEN,1)) ;write team info + Q:'$D(@STORE@(INST,TIEN,"D")) W ! + S NXT="" + ;write team description + F S NXT=$O(@STORE@(INST,TIEN,"D",NXT)) Q:NXT=""!(STOP) D + .I (IOST'?1"C-".E)&$Y>(IOSL-13) D NEWP1^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + .I (IOST?1"C-".E)&$Y>(IOSL-13) D HOLD^SCRPU3(.PAGE,TITL,132) W:'STOP !,$G(@STORE@(INST)) + .Q:STOP + .W !,$G(@STORE@(INST,TIEN,"D",NXT)) + W !!,"[Not Assigned] = Patient assigned to Team but not to a position/provider" + W !,"[Inactive Position] = Patient assigned to Team & Position but has no active provider" + Q + ; +HEADER ;prints column headings + N NXT + F NXT="H1","H2","H3" D + .W !,$G(@STORE@(NXT)) + Q + ; +SETH ;sets column headings + S @STORE@("H2")="Patient Name" + S $E(@STORE@("H2"),25)="Pt ID" + S $E(@STORE@("H2"),32)="Practitioner" + S $E(@STORE@("H2"),56)="Role" + S $E(@STORE@("H2"),80)="PC?" + S $E(@STORE@("H1"),85)="Last" + S $E(@STORE@("H2"),85)="Appt." + S $E(@STORE@("H1"),97)="Next" + S $E(@STORE@("H2"),97)="Appt." + S $E(@STORE@("H2"),109)="Associated Clinic" + S $P(@STORE@("H3"),"=",133)="" + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPTP3.m (revision 623) @@ -1,116 +1,148 @@ -SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM - ;;5.3;Scheduling;**41,48,98,177,231,433,526,520**;AUG 13, 1993;Build 26 - ;;DMR BP-OIFO Patch SD*5.3*526 - ; - ;List of Team's Patients Report - ; -HITS(ARRY,TIEN) ; - ;ARRY - list of patients for a given team - ;TIEN - team ien - ; - N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT - N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE - N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN - S INACTIVE=0 - S NXT=0 - F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D - .S NODE=$G(@ARRY@(NXT)) - .Q:NODE="" - .S PTIEN=+$P(NODE,"^") ;patient ien - .S PTNAME=$P(NODE,"^",2) ;patient name - .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42) - .; - .S PNODE=$G(^DPT(PTIEN,0)) - .Q:PNODE="" - .S DFN=PTIEN - .D PID^VADPT6 - .;S PID=VA("BID") - .S PID=$E(VA("PID"),1,3)_$E(VA("PID"),5,6)_$E(VA("PID"),8,12) - .; - .N CNAME,PINF,CLIEN - .S CNT="" - .F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D - ..D TPAR(PTAI,CNT,.PINF,.CNAME,.CLIEN,.PNAME,.ROLN,.PCAP) - Q - ; -TPAR(PTAI,START,PINF,CNAME,CLIEN,PNAME,ROLN,PCAP) ; - N PTPA,TPIEN,TPNODE,ROL,CIEN,ENROLL,OKAY,NEXT,LAST,PAIEN - I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]" - ; ^ no patient team position assignment - IF START="" D - .S PTPA=$O(^SCPT(404.43,"B",PTAI,START)) - ELSE D - .S PTPA=START - I PTPA="" Q "0^[Not Assigned]" - S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team assignment - I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]" - I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)
0:" AP",1:"PCP") ;PC? - ; - D SETASCL^SCRPRAC2(TPIEN,.CNAME,.CLIEN) - ;next two lines commented off - SD*5.3*433 - ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic - ;I 'ENROLL S CNAME="",CIEN=0 - ; - S PAIEN=$$CHK(TPIEN) - I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name - ;SD*5.3*231 - I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]" - ; - D GETPINF^SCRPPAT2(PTIEN,.CLIEN,.PINF) ;get patient info - S CNAME=$G(CNAME(0)) - S PINF=$G(PINF(0)) - I PINF="" D - .S PINF=PIEN_"^"_$$PDATA^SCRPEC(PIEN,CNAME,CNAME,1) - I INACTIVE S @STORE@(INS,TIEN,"INACT")="" - S FLAG="Y" - S TINFO=$$TINF^SCRPTP(TIEN) ;team information - S INST=+$P(TINFO,"^") ;institution ien - S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name - S PHONE=$P(TINFO,"^",4) ;team phone - S PC=$P(TINFO,"^",3) ;primary care? - S TNAME=$P(TINFO,"^",2) ;team name - D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC) - D FORMAT^SCRPTP(INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,PINF,ROLN,PCAP) - N SCCNT - S SCCNT=0 F S SCCNT=$O(CNAME(SCCNT)) Q:SCCNT="" D FORMATAC^SCRPTP(SCCNT,CNAME(SCCNT),PINF(SCCNT),INS,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,ROLN,PCAP) - Q - ; -ENRL(PTIEN,CLIEN) ;FUNCTIONALITY DISABLED - ; - ;N FOUND,ENODE,EN,NXT - ;S FOUND=0 - ;Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND - ;S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) - ;Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND - ;S NXT="" - ;F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D - ;check if active enrollment - ;S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) - ;I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment - ;; ^ discharge date ^ enrollment date - S FOUND=0 - Q FOUND - ; -CHK(TPIEN) ;assigned to a position - ;TPIEN - ien of 404.57 Team Position file - ;returns: ien of 200 New Person file - N EN,PLIST,PERR,ERR,NAME - S PLIST="PLST",PERR="PRR" - K @PLIST,@PERR - S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR) - I '$D(@PERR) D - .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file - .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name - K @PLIST,@PERR - Q EN_"^"_NAME - ; +SCRPTP3 ;ALB/CMM - List of Team's Patients ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**41,48,98,177,231,433**;AUG 13, 1993 + ; + ;List of Team's Patients Report + ; +HITS(ARRY,TIEN) ; + ;ARRY - list of patients for a given team + ;TIEN - team ien + ; + N PTIEN,PIEN,PTNAME,PNAME,PTAI,NXT,NODE,CIEN,CNAME,INAME,INST,LAST,NEXT + N PAIEN,PC,PHONE,PNODE,PTPA,PTPAN,ROL,PID,TINFO,TNAME,TPIEN,TPNODE + N CNT,TPA,FLAG,DFN,VA,VAERR,PCAP,ROLN + S INACTIVE=0 + S NXT=0 + F S NXT=$O(@ARRY@(NXT)) Q:NXT=""!(NXT'?.N) D + .S NODE=$G(@ARRY@(NXT)) + .Q:NODE="" + .S PTIEN=+$P(NODE,"^") ;patient ien + .S PTNAME=$P(NODE,"^",2) ;patient name + .S PTAI=+$P(NODE,"^",3) ;patient team assignment ien (#404.42) + .; + .S PNODE=$G(^DPT(PTIEN,0)) + .Q:PNODE="" + .S DFN=PTIEN + .D PID^VADPT6 + .S PID=VA("BID") + .; + .S TPA=$$TPAR(PTAI,"") + .I TPA'=-1 D + ..S PIEN=$P(TPA,"^") + ..S PNAME=$P(TPA,"^",2) + ..S CNAME=$P(TPA,"^",3) + ..S LAST=$P(TPA,"^",4) + ..S NEXT=$P(TPA,"^",5) + ..; + ..S FLAG="Y" + ..S TINFO=$$TINF^SCRPTP(TIEN) ;team information + ..S INST=+$P(TINFO,"^") ;institution ien + ..S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name + ..S PHONE=$P(TINFO,"^",4) ;team phone + ..S PC=$P(TINFO,"^",3) ;primary care? + ..S TNAME=$P(TINFO,"^",2) ;team name + ..; + ..D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC) + ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT) + .; + .;check for other assignments + .N TPIN + .S CNT="" + .F S CNT=$O(^SCPT(404.43,"B",PTAI,CNT)) Q:CNT=""!(CNT'?.N) D + ..S TPIN=$$TPAR(PTAI,CNT) + ..Q:TPIN=-1 + ..S PIEN=$P(TPIN,"^") + ..S PNAME=$P(TPIN,"^",2) + ..S CNAME=$P(TPIN,"^",3) + ..S LAST=$P(TPIN,"^",4) + ..S NEXT=$P(TPIN,"^",5) + ..S ROLN=$P(TPIN,U,6) + ..S PCAP=$P(TPIN,U,7) + ..I '$D(FLAG) D + ...S TINFO=$$TINF^SCRPTP(TIEN) ;team information + ...S INST=+$P(TINFO,"^") ;institution ien + ...S INAME=$P($G(^DIC(4,INST,0)),"^") ;institution name + ...S PHONE=$P(TINFO,"^",4) ;team phone + ...S PC=$P(TINFO,"^",3) ;primary care? + ...S TNAME=$P(TINFO,"^",2) ;team name + ...; + ...D TFORMAT^SCRPTP2(INST,INAME,TIEN,TNAME,PHONE,PC) + ..D FORMAT^SCRPTP(INST,TIEN,PTIEN,PTNAME,PID,PIEN,PNAME,CNAME,LAST,NEXT,ROLN,PCAP) + I INACTIVE S @STORE@(INST,TIEN,"INACT")="" + Q + ; +TPAR(PTAI,START) ; + N PTPA,TPIEN,TPNODE,ROL,CNAME,CIEN,ENROLL,OKAY,PNAME,NEXT,LAST,PAIEN + N ROLN,PCAP + I '$D(^SCPT(404.43,"B",PTAI)) Q "0^[Not Assigned]" + ; ^ no patient team position assignment + IF START="" D + .S PTPA=$O(^SCPT(404.43,"B",PTAI,START)) + ELSE D + .S PTPA=START + I PTPA="" Q "0^[Not Assigned]" + S PTPAN=$G(^SCPT(404.43,PTPA,0)) ;patient team position assignment node + I PTPAN=""!(PTPAN=0) Q "0^[Not Assigned]" + I $P(PTPAN,"^",4)'="",$P(PTPAN,"^",4)
0:" AP",1:"PCP") ;PC? + ; + S CIEN=+$P(TPNODE,"^",9) ;associated clinic ien + S CNAME=$P($G(^SC(CIEN,0)),"^") ;clinic name + ;check patient status + S OKAY="" + I CIEN>0&(PSTAT'=1) S OKAY=$$PST^SCRPTP(PTIEN,CIEN) + Q:(CIEN>0)&('OKAY)&(PSTAT'=1) -1 + ; ^ not selected patient status + ; + ;next two lines commented off - SD*5.3*433 + ;S ENROLL=$$ENRL(PTIEN,CIEN) ;enrolled in associated clinic + ;I 'ENROLL S CNAME="",CIEN=0 + ; + S PAIEN=$$CHK(TPIEN) + I +PAIEN'=0 S PIEN=+PAIEN,PNAME=$P(PAIEN,"^",2) ; practitioner's name + ;SD*5.3*231 + I +PAIEN=0 S PIEN=0,PNAME="[Inactive Position]" + ; + S (NEXT,LAST)="" + I +CIEN>0 S NEXT=$$GETNEXT^SCRPU3(PTIEN,CIEN) ;next appointment + I +CIEN>0 S LAST=$$GETLAST^SCRPU3(PTIEN,CIEN) ;last appointment + ; + Q PIEN_U_PNAME_U_CNAME_U_LAST_U_NEXT_U_ROLN_U_PCAP + ; +ENRL(PTIEN,CLIEN) ; + ; + N FOUND,ENODE,EN,NXT + S FOUND=0 + Q:'$D(^DPT(PTIEN,"DE","B",CLIEN)) FOUND + S EN=$O(^DPT(PTIEN,"DE","B",CLIEN,"")) + Q:EN=""!'$D(^DPT(PTIEN,"DE",EN,1)) FOUND + S NXT="" + F S NXT=$O(^DPT(PTIEN,"DE",EN,1,NXT)) Q:(FOUND)!(NXT="")!(NXT'?.N) D + .;check if active enrollment + .S ENODE=$G(^DPT(PTIEN,"DE",EN,1,NXT,0)) + .I $P(ENODE,"^",3)'="",$P(ENODE,"^",3)DT Q ;not active enrollment + .; ^ discharge date ^ enrollment date + .S FOUND=1 + Q FOUND + ; +CHK(TPIEN) ;assigned to a position + ;TPIEN - ien of 404.57 Team Position file + ;returns: ien of 200 New Person file + N EN,PLIST,PERR,ERR,NAME + S PLIST="PLST",PERR="PRR" + K @PLIST,@PERR + S ERR=$$PRTP^SCAPMC8(TPIEN,,.PLIST,.PERR) + I '$D(@PERR) D + .S EN=$P($G(@PLIST@(1)),"^") ;ien of new person file + .S NAME=$P($G(@PLIST@(1)),"^",2) ; new person name + K @PLIST,@PERR + Q EN_"^"_NAME + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU1.m (revision 623) @@ -1,131 +1,131 @@ -SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96 - ;;5.3;Scheduling;**41,45,130,520**;AUG 13, 1993;Build 26 - ; -INST ;Prompt for institution - S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" - S VAUTNI=2,VAUTSTR="Division" - G FIRST^VAUTOMA - ; -PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection - I '$D(VAUTD) G ERR - S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")="" - S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))" - G FIRST - ; -CLINIC ;Prompt for Clinic - I '$D(VAUTT)&'$D(VAUTCA) G ERR - S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC(" - ;Set screen to only allow clinics and clinics that are associated to the teams selected - I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()" - ;VAUTCA allows for selection of any clinic in the selected - I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()" - G FIRST - ; -USER ;Prompt for User Class - I '$D(VAUTT) G ERR - I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q ;user class turned off - S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2 - S DIC("S")="I $$USRCL^SCRPU1" - G FIRST - ; -USRCL() ;Screen for user class - must be related to teams selected - N STOP,ENT,NODE,TIEN - I '+$P(^(0),U,3) Q 0 - ;check for active/exiting user class - S ENT=0,STOP=0 - F S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP) D - .S NODE=$G(^SCTM(404.57,ENT,0)) - .I NODE="" S STOP=0 Q - .S TIEN=+$P(NODE,"^",2) ;team ien - .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q - .I VAUTT=""&(TIEN="") S STOP=1 Q ;no team selected, no team assigned - .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0 - Q STOP - ; -ROLE ;Prompt for Role - I '$D(VAUTT) G ERR - S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2 - S DIC("S")="I $$RL^SCRPU1()" - G FIRST - ; -RL() ;Screen for Role - screen on team - N EN,STOP,ACT,TEAM - S EN="",STOP=0 - I $D(^SCTM(404.57,"AC",+Y)) D - .F S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP) D - ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active? - ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q - ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2) - ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1 - ..I VAUTT=""&(TEAM="") S STOP=1 - Q STOP - ; -PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s) - I '$D(VAUTT) G ERR - S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200," - S DIC("S")="I $$PRACS^SCRPU1()" - G FIRST - ; -PRACS() ;Practitioner screen - off of team selection - N EN,STOP,NODE,TEAM - S EN="",STOP=0 - I '$D(^SCTM(404.52,"C",+Y)) Q 0 - ;Position Assignment History file - F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D - .I '$D(^SCTM(404.52,EN)) Q - .S NODE=$G(^SCTM(404.52,EN,0)) - .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2) - .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1 - .I VAUTT=1 S STOP=1 - Q STOP - ; -FIRST ; - S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB - S (@VAUTVB,Y)=0 -REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3 - G:$G(SCOKNULL)&(X="") QUIT - I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT - ;VAUTNA doesn't allow all to be selected - ;VAUTTN allows 'Not assigned to a team' as a selection - I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT - ;VAUTPP allows 'Not assigned to a practitioner' as a selection - S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET - I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1 - ;VAUTPO - only one practitioner allowed to be selected - G QUIT -SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q - S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1 - S @VAUTVB@(+Y)=$P(Y(0),U) - Q - ; -ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP="" -QUIT S:'$D(Y) Y=1 - I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10") - K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X - Q - ; -CLSC() ;screen on clinic selection, must be related to team prompt - I $P(^(0),U,3)'="C" Q 0 - N TRUE,EN,TEAM - S TRUE=0,EN="" - F S EN=$O(^SCTM(404.57,"E",+Y,EN)) Q:EN=""!(TRUE) D - .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2) - .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1 - I VAUTT="" S TRUE=1 - Q TRUE - ; -CLSC2() ;screen on clinic selection, must be a clinic - I $P(^(0),U,3)'="C" Q 0 - Q 1 - ; -CLSC2OLD() ;screen on clinic selection, must be related to division prompt - I $P(^(0),U,3)'="C" Q 0 - N TRUE,EN,INST,TDIV - S TRUE=0,EN="" - S TDIV=+$P(^(0),U,15) ;clinic's division - Q:TDIV=0 0 - S INST=+$P(^DG(40.8,TDIV,0),U,7) - I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0 - I $D(VAUTD(INST)) S TRUE=1 - I VAUTD=1 S TRUE=1 - Q TRUE +SCRPU1 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ;1/12/96 + ;;5.3;Scheduling;**41,45,130**;AUG 13, 1993 + ; +INST ;Prompt for institution + S VAUTVB="VAUTD",DIC="^DIC(4,",DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))" + S VAUTNI=2,VAUTSTR="Division" + G FIRST^VAUTOMA + ; +PRMTT ;Prompt for team. Set VAUTTN to allow not assigned to a team as a selection + I '$D(VAUTD) G ERR + S VAUTVB="VAUTT",DIC="^SCTM(404.51,",VAUTNI=2,VAUTSTR="Team",DIC("B")="" + S DIC("S")="I VAUTD=1!($D(VAUTD(+$P(^(0),U,7))))" + G FIRST + ; +CLINIC ;Prompt for Clinic + I '$D(VAUTT)&'$D(VAUTCA) G ERR + S VAUTVB="VAUTC",VAUTSTR="Clinic",VAUTNI=2,DIC="^SC(" + ;Set screen to only allow clinics and clinics that are associated to the teams selected + I '$D(VAUTCA) S DIC("S")="I $$CLSC^SCRPU1()" + ;VAUTCA allows for selection of any clinic in the selected + I $D(VAUTCA) S DIC("S")="I $$CLSC2^SCRPU1()" + G FIRST + ; +USER ;Prompt for User Class + I '$D(VAUTT) G ERR + I $P($G(^SD(404.91,1,"PCMM")),"^")'=1 Q ;user class turned off + S VAUTVB="VAUTUC",DIC="^USR(8930,",VAUTSTR="User Class",VAUTNI=2 + S DIC("S")="I $$USRCL^SCRPU1" + G FIRST + ; +USRCL() ;Screen for user class - must be related to teams selected + N STOP,ENT,NODE,TIEN + I '+$P(^(0),U,3) Q 0 + ;check for active/exiting user class + S ENT=0,STOP=0 + F S ENT=$O(^SCTM(404.57,"AUSR",+Y,ENT)) Q:ENT=""!(STOP) D + .S NODE=$G(^SCTM(404.57,ENT,0)) + .I NODE="" S STOP=0 Q + .S TIEN=+$P(NODE,"^",2) ;team ien + .I $D(VAUTT(TIEN))!(VAUTT=1) S STOP=1 Q + .I VAUTT=""&(TIEN="") S STOP=1 Q ;no team selected, no team assigned + .I VAUTT'=1&('$D(VAUTT(TIEN))) S STOP=0 + Q STOP + ; +ROLE ;Prompt for Role + I '$D(VAUTT) G ERR + S VAUTVB="VAUTR",DIC="^SD(403.46,",VAUTSTR="Role",VAUTNI=2 + S DIC("S")="I $$RL^SCRPU1()" + G FIRST + ; +RL() ;Screen for Role - screen on team + N EN,STOP,ACT,TEAM + S EN="",STOP=0 + I $D(^SCTM(404.57,"AC",+Y)) D + .F S EN=$O(^SCTM(404.57,"AC",+Y,EN)) Q:EN=""!(STOP) D + ..S ACT=+$$ACTTP^SCMCTPU(EN) ;currently active? + ..I 'ACT!('$D(^SCTM(404.57,EN,0))) Q + ..S TEAM=$P(^SCTM(404.57,EN,0),"^",2) + ..I $D(VAUTT(TEAM))!(VAUTT=1) S STOP=1 + ..I VAUTT=""&(TEAM="") S STOP=1 + Q STOP + ; +PRACT ; Prompt for One (set VAUTPO) or One,Many,All,None Practitioner(s) + I '$D(VAUTT) G ERR + S VAUTVB="VAUTP",VAUTSTR="Practitioner",VAUTNI=2,DIC="^VA(200," + S DIC("S")="I $$PRACS^SCRPU1()" + G FIRST + ; +PRACS() ;Practitioner screen - off of team selection + N EN,STOP,NODE,TEAM + S EN="",STOP=0 + I '$D(^SCTM(404.52,"C",+Y)) Q 0 + ;Position Assignment History file + F S EN=$O(^SCTM(404.52,"C",+Y,EN)) Q:EN=""!(STOP) D + .I '$D(^SCTM(404.52,EN)) Q + .S NODE=$G(^SCTM(404.52,EN,0)) + .S TEAM=+$P($G(^SCTM(404.57,$P(NODE,"^"),0)),"^",2) + .I $P(NODE,"^",4),$D(VAUTT(TEAM)) S STOP=1 + .I VAUTT=1 S STOP=1 + Q STOP + ; +FIRST ; + S DIC(0)="EQMNZ",DIC("A")="Select "_VAUTSTR_": " K @VAUTVB + S (@VAUTVB,Y)=0 +REDO W !,DIC("A") R X:DTIME G ERR:(X="^")!'$T D:X["?"!(X=""&('$G(SCOKNULL))) HELP^SCRPU3 + G:$G(SCOKNULL)&(X="") QUIT + I X="A"!(X="ALL")&'$D(VAUTNA) S @VAUTVB=1 G QUIT + ;VAUTNA doesn't allow all to be selected + ;VAUTTN allows 'Not assigned to a team' as a selection + I X="N"!(X="NOT")!(X="NONE") I $D(VAUTTN)!($D(VAUTPP)) S @VAUTVB="" G QUIT + ;VAUTPP allows 'Not assigned to a practitioner' as a selection + S DIC("A")="Select another "_VAUTSTR_": " D ^DIC G:Y'>0 FIRST D SET + I '$D(VAUTPO) F VAI=1:0:19 W !,DIC("A") R X:DTIME G ERR:(X="")!(X="^")!'$T K Y D HELP^SCRPU3:X["?" S:$E(X)="-" VAUTX=X,X=$E(VAUTX,2,999) D ^DIC I Y>0 D SET G:VAX REDO S:'VAERR VAI=VAI+1 + ;VAUTPO - only one practitioner allowed to be selected + G QUIT +SET S VAX=0 I $D(VAUTX) S J=$S(VAUTNI=2:+Y,1:$P(Y(0),"^")) K VAUTX S VAERR=$S($D(@VAUTVB@(J)):0,1:1) W $S('VAERR:"...removed from list...",1:"...not on list...can't remove") Q:VAERR S VAI=VAI-1 K @VAUTVB@(J) S:$O(@VAUTVB@(0))']"" VAX=1 Q + S VAERR=0 I $S($D(@VAUTVB@($P(Y(0),U))):1,$D(@VAUTVB@(+Y)):1,1:0) W !?3,*7,"You have already selected that ",VAUTSTR,". Try again." S VAERR=1 + S @VAUTVB@(+Y)=$P(Y(0),U) + Q + ; +ERR S Y=-1 I $O(@VAUTVB@(0))="" K @VAUTVB I X="^" S SCUP="" +QUIT S:'$D(Y) Y=1 + I $D(@VAUTVB),VAUTSTR="Team",@VAUTVB=1 D:'$G(DGQUIET) EN^DDIOL("All Teams selected, this report may take some time...","","!,?10") + K DIC,J,VAERR,VAI,VAJ,VAJ1,VAX,VAUTNI,VAUTSTR,VAUTVB,X + Q + ; +CLSC() ;screen on clinic selection, must be related to team prompt + I $P(^(0),U,3)'="C" Q 0 + N TRUE,EN,TEAM + S TRUE=0,EN="" + F S EN=$O(^SCTM(404.57,"D",+Y,EN)) Q:EN=""!(TRUE) D + .S TEAM=+$P($G(^SCTM(404.57,EN,0)),"^",2) + .I $D(VAUTT(TEAM))!(VAUTT=1) S TRUE=1 + I VAUTT="" S TRUE=1 + Q TRUE + ; +CLSC2() ;screen on clinic selection, must be a clinic + I $P(^(0),U,3)'="C" Q 0 + Q 1 + ; +CLSC2OLD() ;screen on clinic selection, must be related to division prompt + I $P(^(0),U,3)'="C" Q 0 + N TRUE,EN,INST,TDIV + S TRUE=0,EN="" + S TDIV=+$P(^(0),U,15) ;clinic's division + Q:TDIV=0 0 + S INST=+$P(^DG(40.8,TDIV,0),U,7) + I '$D(VAUTD(INST))&(VAUTD'="") S TRUE=0 + I $D(VAUTD(INST)) S TRUE=1 + I VAUTD=1 S TRUE=1 + Q TRUE Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPU2.m (revision 623) @@ -1,146 +1,146 @@ -SCRPU2 ;ALB/CMM - GENERIC PROMPTS FOR PCMM REPORTS ; 12 Jan 99 1:23 PM - ;;5.3;Scheduling;**41,174,297,526,520**;AUG 13, 1993;Build 26 - ; -DTRANG(FIRST,SECOND) ;Date Range - begin date ^ end date => fileman format - ;FIRST - first prompt (not required) - ;SECOND - second prompt (not required) - N BDATE,EDATE,DIROUT,DUOUT,DTOUT - S EDATE=-1 - S DIR(0)="D^::E",DIR("B")="Today" - I '$D(FIRST) S DIR("A")="Begin Date" - I $D(FIRST) S DIR("A")=FIRST - D ^DIR - I $D(DTOUT)!(X="Today") S BDATE=$P(DT,".") - I $D(DUOUT)!($D(DIROUT)) Q -1 - S BDATE=+Y -DEN I '$D(SECOND) S DIR("A")="End Date" - I $D(SECOND) S DIR("A")=SECOND - K DTOUT,X,Y - D ^DIR - I $D(DTOUT)!(X="Today") S EDATE=$P(DT,".") - I $D(DUOUT)!($D(DIROUT)) Q -1 - S EDATE=+Y - I EDATE fileman format + ;FIRST - first prompt (not required) + ;SECOND - second prompt (not required) + N BDATE,EDATE,DIROUT,DUOUT,DTOUT + S EDATE=-1 + S DIR(0)="D^::E",DIR("B")="Today" + I '$D(FIRST) S DIR("A")="Begin Date" + I $D(FIRST) S DIR("A")=FIRST + D ^DIR + I $D(DTOUT)!(X="Today") S BDATE=$P(DT,".") + I $D(DUOUT)!($D(DIROUT)) Q -1 + S BDATE=+Y +DEN I '$D(SECOND) S DIR("A")="End Date" + I $D(SECOND) S DIR("A")=SECOND + K DTOUT,X,Y + D ^DIR + I $D(DTOUT)!(X="Today") S EDATE=$P(DT,".") + I $D(DUOUT)!($D(DIROUT)) Q -1 + S EDATE=+Y + I EDATESDXEDT S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT) - G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT - I $P(SDDIV,U,2)="SELECTED DIVISIONS" D - .S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI S SDIV(SDDIV(SDI))=SDI - .Q - I $P(SDDIV,U,2)="ALL DIVISIONS" D - .S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI - .Q - S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3) - G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV) - G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV) - I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR - ; -EXIT K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q - ; -DPRT(SDIV) ;Print division - K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT W !!?(IOM-$L(SDX)\2),SDX Q - S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT D LINE(SDDT) F S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT D LINE(SDDT) - D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT F W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6) - W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a" - W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'. This excludes any 'action required' activity." - Q - ; -DIV(SDD) ;Check division - ;Required input: MEDICAL CENTER DIVISION pointer - Q:'SDDIV 1 - Q $D(SDDIV(SDD)) - ; -SET(SDIV) ;Set TMP global - S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT - Q:'SDIV D SET1(SDIV) D:SDMD SET1(0) Q - ; -SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q - ; -OENC S SDXDT=SDBDT,SDDFN=0 - F S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN S SDDT=SDXDT F S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT) D OENC1 - Q - ; -OENC1 S SDOE=0 F S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV) - Q - ; -OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter - ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node - ; SDSTA=2 -outpatient,8 -inpatient, 2^8 -both - ;Output: '1' if checked out "parent" encounter, '0' otherwise - I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0 - S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^" - Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1 - Q 0 - ; -STOP ;Check for stop task request - S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -HDR D STOP Q:SDOUT I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?36,"<*> TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES <*>" - N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI - S SDI=0 F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI) - W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q - ; -HD1 Q:SDOUT W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q - ; -DTINC(SDDT) ;Increment date by one month - ;Required input: SDDT=date - ;Output: next month to examine - Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100" - Q $E(SDDT,1,5)+1_"00" - ; -LOOK S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN D L1 - Q - ; -L1 I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q - S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX(IOSL-3) HDR,HD1 Q:SDOUT S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO - S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1) - W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*" - Q +SCRPW6 ;RENO/KEITH - Trend of Facility Uniques by 12 Month Date Ranges ; 15 Jul 98 02:38PM + ;;5.3;Scheduling;**139,144,466**;AUG 13, 1993;Build 2 + N SDDIV,SDI,SDSTA,DIR D TITL^SCRPW50("Trend of Facility Uniques by 12 Month Date Ranges") G:'$$DIVA^SCRPW17(.SDDIV) EXIT + D SUBT^SCRPW50("**** Status Selection ****") + S DIR(0)="S^1:Checked Out (Outpatients);2:Checked Out (Inpatients);3:Checked Out (Out/Inpatients)",DIR("A")="Select Status",DIR("B")="1" + D ^DIR I $D(DTOUT)!$D(DUOUT)!(+Y<0) G EXIT + S SDSTA=$S(Y=1:2,Y=2:8,1:"2^8") +QUE W !!,"This report requires 132 column output.",! + N ZTSAVE F X="SDDIV","SDDIV(","SDDNU(",SDSTA S ZTSAVE(X)="" + D EN^XUTMDEVQ("UNIQ^SCRPW6","Trend Facility Uniques",.ZTSAVE),DISP0^SCRPW23 Q +UNIQ ;Calculate/print uniques + S (SDOUT,SDSTOP)=0,SDLINE="",SDPAGE=1,$P(SDLINE,"-",133)="" D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDMD=$O(SDDIV(0)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1 + K ^TMP("SCRPW",$J) S SDBDT=$E(DT,1,3)-5_$E(DT,4,5)_"00",SDEDT=$E(DT,1,5)_"00",SDXEDT=$E(DT,1,3)-1_$E(DT,4,5)_"00" D OENC G:SDOUT EXIT + S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D STOP Q:SDOUT D + .S SDDT=SDBDT,SDXDT=$$YDTINC(SDDT),^TMP("SCRPW",$J,SDIV,"YR","MAX")=0 D LOOK + .F S SDDT=$$DTINC(SDDT) Q:SDDT>SDXEDT S SDXDT=$$YDTINC(SDDT) D LOOK I ^TMP("SCRPW",$J,SDIV,"YR",SDDT)>^TMP("SCRPW",$J,SDIV,"YR","MAX") S ^TMP("SCRPW",$J,SDIV,"YR","MAX")=^TMP("SCRPW",$J,SDIV,"YR",SDDT) + G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 I '$D(^TMP("SCRPW",$J)) D HDR G:SDOUT EXIT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT + I $P(SDDIV,U,2)="SELECTED DIVISIONS" D + .S SDI=0 F S SDI=$O(SDDIV(SDI)) Q:'SDI S SDIV(SDDIV(SDI))=SDI + .Q + I $P(SDDIV,U,2)="ALL DIVISIONS" D + .S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:'$L(SDX) SDX="***UNKNOWN***" S SDIV(SDX)=SDI + .Q + S:$D(SDIV)'>1 SDIV($P(SDDIV,U,2))=$P(SDDIV,U,3) + G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV) + G:SDOUT EXIT S SDMD=0,SDMD=$O(^TMP("SCRPW",$J,SDMD)),SDMD=$O(^TMP("SCRPW",$J,SDMD)) I SDMD S SDIV=0 D DPRT(.SDIV) + I $E(IOST)="C",'SDOUT W ! N DIR S DIR(0)="E" D ^DIR + ; +EXIT K SDIV,SDIVN,SDMD,SDOUT,SDSTOP,SDDIV,SDBDT,SDCT,SDDFN,SDDT,SDEDT,SDFIG,SDI,SDLINE,SDMAX,SDMO,SDOE,SDOE0,SDPAGE,SDPNOW,SDXDT,SDXEDT,SDXMO,SDXYR,SDYR,Y,%,SDX,SDFIG1,DTOUT,DUOUT,X,Y D END^SCRPW50 Q + ; +DPRT(SDIV) ;Print division + K SDTIT D DHDR^SCRPW46(SDIV,1,.SDTIT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDX="No activity within report parameters found for this division!" D HDR Q:SDOUT W !!?(IOM-$L(SDX)\2),SDX Q + S SDDT=SDBDT D FIG,HDR,HD1 Q:SDOUT D LINE(SDDT) F S SDDT=$O(^TMP("SCRPW",$J,SDIV,"YR",SDDT)) Q:'SDDT!SDOUT D LINE(SDDT) + D:$Y>($S(IOSL<80:IOSL,1:80)-5) HDR Q:SDOUT F W ! Q:$Y>($S(IOSL<80:IOSL,1:80)-6) + W !?25,"Uniques in this report are based on OUTPATIENT ENCOUNTER file records with a" + W !?25,"status of '"_$S(SDSTA=2:"",SDSTA=8:"inpatient appointment ",1:"Out/Inpatient ")_"checked out'. This excludes any 'action required' activity." + Q + ; +DIV(SDD) ;Check division + ;Required input: MEDICAL CENTER DIVISION pointer + Q:'SDDIV 1 + Q $D(SDDIV(SDD)) + ; +SET(SDIV) ;Set TMP global + S SDSTOP=SDSTOP+1 D:SDSTOP#2000=0 STOP Q:SDOUT + Q:'SDIV D SET1(SDIV) D:SDMD SET1(0) Q + ; +SET1(SDIV) S ^TMP("SCRPW",$J,SDIV,"PT",SDDFN,$E(SDDT,1,5)_"00")="" Q + ; +OENC S SDXDT=SDBDT,SDDFN=0 + F S SDDFN=$O(^SCE("ADFN",SDDFN)) Q:'SDDFN S SDDT=SDXDT F S SDDT=$O(^SCE("ADFN",SDDFN,SDDT)) Q:'SDDT!(SDDT>SDEDT) D OENC1 + Q + ; +OENC1 S SDOE=0 F S SDOE=$O(^SCE("ADFN",SDDFN,SDDT,SDOE)) Q:'SDOE S SDOE0=$$GETOE^SDOE(SDOE) I $$OE(SDOE0,SDSTA) S SDIV=$P(SDOE0,U,11) I SDIV,$$DIV(SDIV) D SET(SDIV) + Q + ; +OE(SDOE0,SDSTA) ;Evaluate (in)outpatient encounter + ;Required input: SDOE0=OUTPATIENT ENCOUNTER zeroeth node + ; SDSTA=2 -outpatient,8 -inpatient, 2^8 -both + ;Output: '1' if checked out "parent" encounter, '0' otherwise + I $P(SDOE0,U,4),$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q 0 + S SDSTA=$G(SDSTA,2),SDSTA="^"_SDSTA_"^" + Q:'$P(SDOE0,U,6)&(SDSTA[$P(SDOE0,U,12))&($P(SDOE0,U,7)'="") 1 + Q 0 + ; +STOP ;Check for stop task request + S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +HDR D STOP Q:SDOUT I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?36,"<*> TREND OF FACILITY UNIQUES BY 12 MONTH DATE RANGES <*>" + N SDI S SDI=$S(SDSTA=2:"Checked Out - Outpatients",SDSTA=8:"Checked Out - Inpatients",1:"Checked Out - Out/Inpatients") W !,?53,SDI ;?(132-SDI\2),SDI + S SDI=0 F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(132-$L(SDTIT(SDI))\2),SDTIT(SDI) + W !,SDLINE,!,"Date printed: ",SDPNOW,?125,"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q + ; +HD1 Q:SDOUT W !!,"12 mo. date range",?23,"Uniques",?32,"| Histogram (each ""*"" equals ",SDFIG," unique",$S(SDFIG=1:"",1:"s"),")",!,$E(SDLINE,1,SDFIG1) Q + ; +DTINC(SDDT) ;Increment date by one month + ;Required input: SDDT=date + ;Output: next month to examine + Q:$E(SDDT,4,5)=12 $E(SDDT,1,3)+1_"0100" + Q $E(SDDT,1,5)+1_"00" + ; +LOOK S ^TMP("SCRPW",$J,SDIV,"YR",SDDT)=0,SDDFN=0 F S SDDFN=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN)) Q:'SDDFN D L1 + Q + ; +L1 I $D(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) D LSET Q + S SDX=$O(^TMP("SCRPW",$J,SDIV,"PT",SDDFN,SDDT)) I SDX,SDX(IOSL-3) HDR,HD1 Q:SDOUT S SDCT=^TMP("SCRPW",$J,SDIV,"YR",SDDT),SDMO=$E(SDDT,4,5),SDYR=(17+$E(SDDT))_$E(SDDT,2,3),SDXMO=SDMO-1 S:SDXMO=0 SDXMO=12 S:$L(SDXMO)=1 SDXMO=0_SDXMO + S SDXYR=$S(SDXMO=12:SDYR,1:SDYR+1) + W !,SDMO,"/",SDYR," thru ",SDXMO,"/",SDXYR,?24,$J(SDCT,6,0),?32,"| " F SDI=1:1:(SDCT\SDFIG) W "*" + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW62.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW62.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW62.m (revision 623) @@ -1,135 +1,121 @@ -SCRPW62 ;BP-CIOFO/KEITH - SC veterans awaiting appointments ; 23 August 2002@20:23 ; Compiled August 20, 2007 14:21:08 - ;;5.3;Scheduling;**267,269,358,491**;AUG 13, 1993;Build 53 - ; - ;Prompt for report parameters - ; - N SDOUT,DIR,DTOUT,DUOUT,SDFMT,SDATES,SDDIV,SDRPT,SDSCVT - N SDELIM,SDX,ZTSAVE,X,Y - S SDOUT=0 - D TITL^SCRPW50("SC Veterans Awaiting Appointments") - W !,"Note: Once the scheduling replacement application has been implemented at your" - W !,"site, this report will no longer be accurate." -RPT D SUBT^SCRPW50("**** Report Type Selection ****") - S DIR(0)="S^E:ENTERED WITH NO APPOINTMENT PROVIDED;A:APPOINTMENTS BEYOND DATE DESIRED",DIR("A")="Select report type" - S DIR("?",1)="Specify 'E' to return SC veterans entered but not yet provided an appointment," - S DIR("?")="'A' to return SC veterans with appointments beyond the date desired." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - K DIR S SDRPT=Y D ENT:SDRPT="E",APPT:SDRPT="A" G:SDOUT EXIT - D SUBT^SCRPW50("**** Patient Eligibility Selection ****") - S DIR(0)="S^1:50-100% SC Veterans;2:0-50% SC Veterans;3:All SC Veterans" - S DIR("A")="Select eligibility type" - S DIR("?")="Specify the eligibility of the patients you wish to include." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - K DIR S SDSCVT=Y -FMT D SUBT^SCRPW50("**** Report Format Selection ****") - S DIR(0)="S^D:DETAILED REPORT;S:STATISTICS ONLY" - S DIR("A")="Select report format" - S DIR("?")="Specify the report format desired." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - K DIR S SDFMT=Y - I SDFMT="S" S SDELIM=0 G QUE - D SUBT^SCRPW50("**** Output Format Selection ****") - S DIR(0)="Y",DIR("A")="Return report output in delimited format" - S DIR("B")="NO" - S DIR("?",1)="Specify if you would like the report output to be in delimited format for" - S DIR("?",2)="transfer to a spreadsheet. The delimited output will not include rated SC" - S DIR("?")="disabilities for 0-50% SC veterans (as included in the text formatted report)." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT - S SDELIM=Y - ; -QUE ;Queue output - ;W !!,"This report requires ",$S(SDELIM:"greater than ",1:""),"132 columns for output!" - W !!,"This report requires the following steps to be converted to 'EXCEL':" - W !,"1 - Copy it into WORD and replace '!^p' with null" - W !,"2 - Save this file as *.txt format" - W !,"3 - Open this file in 'EXCEL' with the All Files(*.*) type of file, listing it with one delimiter: '^'." - F SDX="SDELIM","SDRPT","SDSCVT","SDATES","SDDIV","SDDIV(","SDFMT" S ZTSAVE(SDX)="" - W ! D EN^XUTMDEVQ("START^SCRPW62","SC Veterans Awaiting Appointments",.ZTSAVE) D DISP0^SCRPW23 - Q - ; -ENT ;Date entered parameters - S SDATES=1 Q - ; - ;Following logic suppressed by request - D SUBT^SCRPW50("**** Report Time Frame ****") - S DIR(0)="S^1:THE PAST YEAR;2:THE PAST TWO YEARS;3:THE PAST 3 YEARS" - S DIR("A")="Include SC veterans entered during" - S DIR("?")="Specify the time frame in which these patients were entered in VistA." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q - S SDATES=Y - Q - ; -APPT ;Appointment delay parameters - I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 Q - S SDATES=30 Q - ; - ;Following logic suppressed by request - D SUBT^SCRPW50("**** Report Time Frame ****") - S DIR(0)="S^30:>30 DAYS BEYOND 'DESIRED DATE';60:>60 DAYS BEYOND 'DESIRED DATE;90:>90 DAYS BEYOND 'DESIRED DATE';180:>180 DAYS BEYOND 'DESIRED DATE'" - S DIR("A")="Include SC veterans with future appointments greater than" - S DIR("?")="Specify the difference between 'desired date' and the appointement date." - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q - S SDATES=Y - Q - ; -START ;Gather report data - N SDSTOP,SDOUT,SDSTOP,SDPAGE,SDLINE,SDPNOW,SDT,SDX - I '$D(ZTQUEUED),$E(IOST)="C" D WAIT^DICD - K ^TMP("SCRPW",$J) S (SDSTOP,SDOUT)=0,SDPAGE=1,SDLINE="" - S $P(SDLINE,"-",(IOM+1))="" - S SDPNOW=$$FMTE^XLFDT($E($$NOW^XLFDT(),1,12)) - S SDX=$S(SDSCVT=1:"SC 50-100% ",SDSCVT=2:"SC < 50% ",1:"") - S SDT(1)="<*> SC VETERANS AWAITING APPOINTMENTS <*>" - S SDT(2)=$S(SDRPT="E":SDX_"PATIENTS ENTERED IN THE PAST "_$S(SDATES=1:"YEAR",1:SDATES_" YEARS")_" WITHOUT AN APPOINTMENT",1:SDX_"PATIENTS WAITING > "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'") - D @(SDRPT_"^SCRPW63") W !! - D EXIT - Q - ; -SCEL(SDE,SDSCVT) ;Gather SC eligibility codes - ;Input: SDE=array to return list of codes in the format SDE(n) where - ; 'n' is the ifn in file #8 (pass by reference) - ; SDSCVT=type of SC vets to include - N SDE81,SDX,SDI,SDII - S SDI=0 F S SDI=$O(^DIC(8.1,SDI)) Q:'SDI D - .S SDX=$G(^DIC(8.1,SDI,0)) - .Q:$P(SDX,U,5)'="Y" S SDX=$P(SDX,U,4) - .I SDSCVT=1,SDX'=1 Q ;50-100% SC only - .I SDSCVT=2,SDX'=3 Q ;0-50% SC only - .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q ;SC only - .S SDII=0 F S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII D - ..S SDE(SDII)=SDX - ..Q - .Q - Q - ; -EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM - D END^SCRPW50 Q - ; -HDR ;Print report header - N X - I SDELIM D HDRD Q - I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - D STOP^SCRPW63 Q:SDOUT - W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) - W:$X $$XY^SCRPW50("",0,0) W SDLINE - S X=0 F S X=$O(SDT(X)) Q:'X W !?(IOM-$L(SDT(X))\2),SDT(X) - W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: " - W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q - ; -HDRD ;Header for delimited report - Q:SDPAGE>1 - W !,SDLINE S X=0 F S X=$O(SDT(X)) Q:'X W !,SDT(X) - W !,"Date printed: ",SDPNOW,!,SDLINE - N ARR S ARR(1)="NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" - S:SDRPT="A" ARR(1)=ARR(1)_"^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" - D DELIM(.ARR) - S SDPAGE=SDPAGE+1 Q - Q - ;W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" - ;W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" - ;S SDPAGE=SDPAGE+1 Q -DELIM(ARR) ;enter delimiter in the end of wrapped line - ;ARR - array of lines - N DELIM,II,LN,LL,JJ - S DELIM="!" - F II=1:1 S LN=$G(ARR(II)),LL=$L(LN) Q:'LL S LN=$P(LN," ")_DELIM_$P(LN," ",2,$L(LN," ")) F JJ=1:79:LL W !,$E(LN,JJ,JJ+78) W:JJ+79 "_SDATES_" DAYS BEYOND APPOINTMENT 'DESIRED DATE'") + D @(SDRPT_"^SCRPW63") W !! + D EXIT + Q + ; +SCEL(SDE,SDSCVT) ;Gather SC eligibility codes + ;Input: SDE=array to return list of codes in the format SDE(n) where + ; 'n' is the ifn in file #8 (pass by reference) + ; SDSCVT=type of SC vets to include + N SDE81,SDX,SDI,SDII + S SDI=0 F S SDI=$O(^DIC(8.1,SDI)) Q:'SDI D + .S SDX=$G(^DIC(8.1,SDI,0)) + .Q:$P(SDX,U,5)'="Y" S SDX=$P(SDX,U,4) + .I SDSCVT=1,SDX'=1 Q ;50-100% SC only + .I SDSCVT=2,SDX'=3 Q ;0-50% SC only + .I SDSCVT=3,(SDX'=1&(SDX'=3)) Q ;SC only + .S SDII=0 F S SDII=$O(^DIC(8,"D",SDI,SDII)) Q:'SDII D + ..S SDE(SDII)=SDX + ..Q + .Q + Q + ; +EXIT K ZTQUEUED,ZTSTOP,SDATES,SDDIV,SDFMT,SDRPT,SDELIM + D END^SCRPW50 Q + ; +HDR ;Print report header + N X + I SDELIM D HDRD Q + I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + D STOP^SCRPW63 Q:SDOUT + W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) + W:$X $$XY^SCRPW50("",0,0) W SDLINE + S X=0 F S X=$O(SDT(X)) Q:'X W !?(IOM-$L(SDT(X))\2),SDT(X) + W !,SDLINE,!,"Date printed: ",SDPNOW,?((IOM-6)-$L(SDPAGE)),"Page: " + W SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1 Q + ; +HDRD ;Header for delimited report + Q:SDPAGE>1 + W !,SDLINE S X=0 F S X=$O(SDT(X)) Q:'X W !,SDT(X) + W !,"Date printed: ",SDPNOW,!,SDLINE + W !,"NAME^SSN^PRIM. ELIG.^DATE ENTERED INTO FILE^STREET ADDRESS^CITY^STATE^ZIP^PHONE NUMBER" + W:SDRPT="A" "^APPOINTMENT DATE^CLINIC^CREDIT PAIR^DIVISION^DATE APPT. ENTERED^DESIRED DATE^DIFFERENCE (DESIRED DATE - APPT. DATE)^DIFFERENCE (DATE APPT. ENTERED - DESIRED DATE)" + S SDPAGE=SDPAGE+1 Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW63.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW63.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW63.m (revision 623) @@ -1,242 +1,241 @@ -SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23 - ;;5.3;Scheduling;**267,269,357,491**;AUG 13, 1993;Build 53 - ; -E ;Gather data for patients entered report - N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT - N SDNAME - D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers - S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0 - ;Find the patients entered after date specified - S DFN=0 F Q:SDSTOP S DFN=$O(^DPT(DFN)) Q:'DFN D - .Q:$D(^DPT(DFN,-9)) ;Skip merged records - .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request - .S SDLVDT="" - .S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) - .S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT - .I SDEDT,SDEDT(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT - ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL) - ...Q - .Q - Q:SDOUT -ESUM ;Print summary - G:SDELIM EQ - S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT - W !! S SDYR="",SDTOT=0 - F S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR="" D - .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL D - ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":" - ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0) - ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL) - ..Q - .Q - W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0) -EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR - Q - ; -SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic - ; Input: DFN=patient ifn - ;Output: '1' if appointments exist, '0' otherwise - N SDI,SDX,SDY - S (SDI,SDY)=0 - F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY D - .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX) - .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q - .S SDY=1 - .Q - Q SDY - ; -A ;Gather data for future appointments report - N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN - N SDREL,SDTOT,SDIV,SD0,SDNAME - D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers - S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP D - .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request - .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets - .S SDEL=SDSCEL(SDEL) - .Q:+$G(^DPT(DFN,.35)) ;No deceased patients - .S SDI=DT F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI D - ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE Q:SDDATE>SDI - ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0) - ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV) ;Division check - ..;Exclude cancelled appointments - ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q - ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES - ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME) - ..;Record detailed information - ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0 - ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1 - ..Q - .Q - Q:SDSTOP - ;Tally up statistics - S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D - .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL D - ..S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D - ...S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN D - ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1 - ....S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D - .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1 - .....Q - ....Q - ...Q - ..Q - .Q - Q:SDSTOP - ;Print report - S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV - I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D - .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE() - .Q - I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D - .F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI D - ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI - ..Q - .Q - D:$E(IOST)="C" DISP0^SCRPW23 - I '$D(^TMP("SCRPW",$J)) D Q ;Negative report - .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62 - .S SDX="No appointments found that meet report criteria." - .I SDELIM W !,SDX Q - .W !!?(IOM-$L(SDX)\2),SDX - .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR - .Q - G:SDFMT="S" ASUM - ;Print detailed report by division - S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D - .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV) - .Q - Q:SDOUT - ;Print summary -ASUM G:SDELIM AQ - S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT - W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN="" - F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" D - .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN) - F S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV D - .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL D - ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT - ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":" - ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0) - ..Q - .Q - W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0) -AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR - Q - ; -DIV(SDIV) ;Check division - S:'$L(SDIV) SDIV=$$PRIM^VASITE() - Q:'SDDIV 1 Q $D(SDDIV(+SDIV)) - ; - ; -STOP ;Check for stop task request - S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -ADPRT(SDIV) ;Print report for a division - D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1 - I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT D Q - .S SDX="No appointments found for this division within report parameters!" - .I SDELIM W !,SDX Q - .W !!?(132-$L(SDX)\2),SDX Q - D HDR^SCRPW62 Q:SDOUT - S SDEL="" F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT D - .S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D - ..S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D - ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) - ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4)) - ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN) - ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT - ...D PLINE(DFN,SD0,SDEL) - ...Q - ..Q - .Q - Q - ; -PLINE(DFN,SD0,SDEL) ;Print patient detail line - ;Input: DFN=patient ifn - ; SD0=zeroeth node of patient record - ; SDEL=1 or 3 to denote SC > or < 50% - ; - N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII - S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16)) - S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10) - S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11)) - S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12) - S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9) - I SDELIM D ;Set up delimited output - .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4) - .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U) - .Q - I 'SDELIM D - .;Print name, SSN, eligibility, date entered, address and phone number - .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN - .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U) - .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST," ",SDZIP - .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U) - .;Print SC disabilities for 0-50% SC veterans - .I SDEL=3 S SDI=0 F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI D - ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3) - ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY) - ..W !?20,"SC disability: ",$P(SDY,U,3)," ",$P(SDY,U) - ..W ?89,"%SC: ",$P(SDX,U,2) - ..Q - .Q - I SDRPT="E" D Q - .I SDELIM S SDZ(1)=SDZ D DELIM^SCRPW62(.SDZ) Q ;W !,SDZ Q - .W ! - .Q - ;Print appointment details for future appointment report - S SDI=0 D - .F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D - ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI) - ..I 'SDELIM D - ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI) - ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: " - ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")" - ...Q - ..I SDELIM D ;Delimited output - ...N SDC0,SDCP,SDCZ,SDADM,SDADME - ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP) - ...S SDII=0,(SDZA,SDADM,SDADME)="" - ...F S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D Q:'SDII - ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN - ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7) - ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0 - ....Q - ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME - ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ - ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0) - ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"") - ...S SDZ(1)=SDZ_SDZA - ...D DELIM^SCRPW62(.SDZ) ;W !,SDZ,SDZA - ...Q - ..Q - .Q - W:'SDELIM ! Q - ; -CSCEL(SDEL) ;Convert SC elig. to external - Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"") +SCRPW63 ;BP-CIOFO/KEITH - SC veterans awaiting appointments (cont.) ; 23 August 2002@20:23 + ;;5.3;Scheduling;**267,269,357**;AUG 13, 1993 + ; +E ;Gather data for patients entered report + N DFN,SDX,SDATE,SD0,SDSCEL,SDEL,SDYR,SDREL,SDTOT,SDSDT,SDLVDT,SDEDT + N SDNAME + D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers + S (SDSDT,SDATE)=DT-(10000*SDATES),SDSTOP=0 + ;Find the patients entered after date specified + S DFN=0 F Q:SDSTOP S DFN=$O(^DPT(DFN)) Q:'DFN D + .Q:$D(^DPT(DFN,-9)) ;Skip merged records + .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request + .S SDLVDT="" + .S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) + .S SDEDT=$P(SD0,U,16) S:SDEDT SDLVDT=SDEDT + .I SDEDT,SDEDT(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT + ...S SDX=^TMP("SCRPW",$J,SDEL,SDNAME,DFN) D PLINE(DFN,SDX,SDEL) + ...Q + .Q + Q:SDOUT +ESUM ;Print summary + G:SDELIM EQ + S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT + W !! S SDYR="",SDTOT=0 + F S SDYR=$O(^TMP("SCRPW",$J,"STATS",SDYR)) Q:SDYR="" D + .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDYR,SDEL)) Q:'SDEL D + ..S SDX=$$CSCEL(SDEL)_" veterans entered "_$S(SDYR=0:"in the past year",SDYR=1:"two years ago",SDYR=2:"three years ago",1:"")_":" + ..W !?36,$J(SDX,45),?83,$J(^TMP("SCRPW",$J,"STATS",SDYR,SDEL),6,0) + ..S SDTOT=SDTOT+^TMP("SCRPW",$J,"STATS",SDYR,SDEL) + ..Q + .Q + W !?36,$E(SDLINE,1,53),!?75,"TOTAL:",?83,$J(SDTOT,6,0) +EQ I $E(IOST,1,2)="C-" N DIR S DIR(0)="E" W !! D ^DIR + Q + ; +SCHAPP(DFN) ;Look for scheduled appointments not cancelled by clinic + ; Input: DFN=patient ifn + ;Output: '1' if appointments exist, '0' otherwise + N SDI,SDX,SDY + S (SDI,SDY)=0 + F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI!SDY D + .S SDX=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDX) + .S SDX=$P(SDX,U,2) I $L(SDX),"CA"[SDX Q + .S SDY=1 + .Q + Q SDY + ; +A ;Gather data for future appointments report + N DFN,SDA0,SDX,SDI,SDSCEL,SDEL,SDDATE,SDIFF,SDAPT,SDIVL,SDIVN + N SDREL,SDTOT,SDIV,SD0,SDNAME + D SCEL^SCRPW62(.SDSCEL,SDSCVT) ;Get eligibility code pointers + S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN!SDSTOP D + .I DFN#1000=0 D STOP Q:SDSTOP ;Check for stop task request + .S SDEL=+$G(^DPT(DFN,.36)) Q:'$D(SDSCEL(SDEL)) ;Only SC vets + .S SDEL=SDSCEL(SDEL) + .Q:+$G(^DPT(DFN,.35)) ;No deceased patients + .S SDI=DT F S SDI=$O(^DPT(DFN,"S",SDI)) Q:'SDI D + ..S SDDATE=+$G(^DPT(DFN,"S",SDI,1)) Q:'SDDATE Q:SDDATE>SDI + ..S SDA0=$G(^DPT(DFN,"S",SDI,0)) Q:'$L(SDA0) + ..S SDIV=$P($G(^SC(+SDA0,0)),U,15) Q:'$$DIV(.SDIV) ;Division check + ..;Exclude cancelled appointments + ..S SDX=$P(SDA0,U,2) I $L(SDX),"PCA"[SDX Q + ..S SDIFF=$$FMDIFF^XLFDT(SDI,SDDATE) Q:SDIFF'>SDATES + ..S SDNAME=$P($G(^DPT(DFN,0)),U) Q:'$L(SDNAME) + ..;Record detailed information + ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)=SDDATE_U_SDA0 + ..S ^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)=$G(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN))+1 + ..Q + .Q + Q:SDSTOP + ;Tally up statistics + S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D + .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL D + ..S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D + ...S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN D + ....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"PTS"))+1 + ....S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D + .....S ^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS")=$G(^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"))+1 + .....Q + ....Q + ...Q + ..Q + .Q + Q:SDSTOP + ;Print report + S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV + I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" D + .S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE() + .Q + I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 D + .F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI D + ..S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI + ..Q + .Q + D:$E(IOST)="C" DISP0^SCRPW23 + I '$D(^TMP("SCRPW",$J)) D Q ;Negative report + .S SDIV=0 D DHDR^SCRPW40(3,.SDT),HDR^SCRPW62 + .S SDX="No appointments found that meet report criteria." + .I SDELIM W !,SDX Q + .W !!?(IOM-$L(SDX)\2),SDX + .I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR + .Q + G:SDFMT="S" ASUM + ;Print detailed report by division + S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT D + .S SDIV=SDIV(SDIVN) D ADPRT(.SDIV) + .Q + Q:SDOUT + ;Print summary +ASUM G:SDELIM AQ + S SDT(3)="STATISTICAL SUMMARY" D HDR^SCRPW62 Q:SDOUT + W !! S (SDTOT,SDIV,SDIVL)=0,SDIVN="" + F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" D + .S SDIVN(SDIV(SDIVN))=SDIVN S:$L(SDIVN)>SDIVL SDIVL=$L(SDIVN) + F S SDIV=$O(^TMP("SCRPW",$J,"STATS",SDIV)) Q:'SDIV D + .S SDEL=0 F S SDEL=$O(^TMP("SCRPW",$J,"STATS",SDIV,SDEL)) Q:'SDEL D + ..S SDAPT=^TMP("SCRPW",$J,"STATS",SDIV,SDEL,"APPTS"),SDTOT=SDTOT+SDAPT + ..S SDX=$$CSCEL(SDEL)_" appointments at "_SDIVN(SDIV)_":" + ..W !?(50-SDIVL),$J(SDX,(28+SDIVL)),?80,$J(SDAPT,6,0) + ..Q + .Q + W !?(50-SDIVL),$E(SDLINE,1,(36+SDIVL)),!?72,"TOTAL:",?80,$J(SDTOT,6,0) +AQ I $E(IOST)="C",'SDOUT N DIR S DIR(0)="E" D ^DIR + Q + ; +DIV(SDIV) ;Check division + S:'$L(SDIV) SDIV=$$PRIM^VASITE() + Q:'SDDIV 1 Q $D(SDDIV(+SDIV)) + ; + ; +STOP ;Check for stop task request + S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +ADPRT(SDIV) ;Print report for a division + D DHDR^SCRPW40(3,.SDT) S:SDELIM SDPAGE=1 + I '$D(^TMP("SCRPW",$J,SDIV)) D HDR^SCRPW62 Q:SDOUT D Q + .S SDX="No appointments found for this division within report parameters!" + .I SDELIM W !,SDX Q + .W !!?(132-$L(SDX)\2),SDX Q + D HDR^SCRPW62 Q:SDOUT + S SDEL="" F S SDEL=$O(^TMP("SCRPW",$J,SDIV,SDEL)) Q:'SDEL!SDOUT D + .S SDNAME="" F S SDNAME=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME)) Q:SDNAME=""!SDOUT D + ..S DFN=0 F S DFN=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN)) Q:'DFN!SDOUT D + ...S SD0=$G(^DPT(DFN,0)) Q:'$L(SD0) + ...S SDREL=$S(SDEL=1:0,1:+$P($G(^DPT(DFN,.372,0)),U,4)) + ...S SDREL=SDREL+^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN) + ...D:$Y>(IOSL-(4+SDREL)) HDR^SCRPW62 Q:SDOUT + ...D PLINE(DFN,SD0,SDEL) + ...Q + ..Q + .Q + Q + ; +PLINE(DFN,SD0,SDEL) ;Print patient detail line + ;Input: DFN=patient ifn + ; SD0=zeroeth node of patient record + ; SDEL=1 or 3 to denote SC > or < 50% + ; + N SDSSN,SDNAME,SDDTE,SDADD,SDST,SDX,SDI,SDY,SDELN,SDZIP,SDZ,SDZA,SDII + S SDNAME=$P(SD0,U),SDSSN=$P(SD0,U,9),SDDTE=$$FMTE^XLFDT($P(SD0,U,16)) + S SDSSN=$E(SDSSN,1,3)_"-"_$E(SDSSN,4,5)_"-"_$E(SDSSN,6,10) + S SDEL=$G(SDEL),SDELN=$$CSCEL(SDEL),SDADD=$G(^DPT(DFN,.11)) + S SDST=$P($G(^DIC(5,+$P(SDADD,U,5),0)),U,2),SDZIP=$P(SDADD,U,12) + S:$L(SDZIP)=9 SDZIP=$E(SDZIP,1,5)_"-"_$E(SDZIP,6,9) + I SDELIM D ;Set up delimited output + .S SDZ=SDNAME_U_SDSSN_U_SDELN_U_SDDTE_U_$P(SDADD,U)_U_$P(SDADD,U,4) + .S SDZ=SDZ_U_SDST_U_SDZIP_U_$P($G(^DPT(DFN,.13)),U) + .Q + I 'SDELIM D + .;Print name, SSN, eligibility, date entered, address and phone number + .W !,"Name: ",SDNAME,?39,"SSN: ",SDSSN,?58,"Prim. Elig.: ",SDELN + .W ?84,"Date entered: ",SDDTE,!?10,"Address: ",$P(SDADD,U) + .W ?55,$P(SDADD,U,4),$S($L($P(SDADD,U,4)):", ",1:""),SDST," ",SDZIP + .W ?88,"Phone number: ",$P($G(^DPT(DFN,.13)),U) + .;Print SC disabilities for 0-50% SC veterans + .I SDEL=3 S SDI=0 F S SDI=$O(^DPT(DFN,.372,SDI)) Q:'SDI D + ..S SDX=$G(^DPT(DFN,.372,SDI,0)) Q:'$P(SDX,U,3) + ..S SDY=$G(^DIC(31,+SDX,0)) Q:'$L(SDY) + ..W !?20,"SC disability: ",$P(SDY,U,3)," ",$P(SDY,U) + ..W ?89,"%SC: ",$P(SDX,U,2) + ..Q + .Q + I SDRPT="E" D Q + .I SDELIM W !,SDZ Q + .W ! + .Q + ;Print appointment details for future appointment report + S SDI=0 D + .F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI)) Q:'SDI D + ..S SDA0=^TMP("SCRPW",$J,SDIV,SDEL,SDNAME,DFN,SDI) + ..I 'SDELIM D + ...W !?30,"Appointment: ",$$FMTE^XLFDT(SDI) + ...W ?63,$P($G(^SC(+$P(SDA0,U,2),0)),U),?96,"Desired date: " + ...W $$FMTE^XLFDT(+SDA0),?124,"(",$$FMDIFF^XLFDT(SDI,+SDA0),")" + ...Q + ..I SDELIM D ;Delimited output + ...N SDC0,SDCP,SDCZ,SDADM,SDADME + ...S SDC0=$G(^SC(+$P(SDA0,U,2),0)),SDCZ=$$CPAIR^SCRPW71(SDC0,.SDCP) + ...S SDII=0,(SDZA,SDADM,SDADME)="" + ...F S SDII=$O(^SC(+$P(SDA0,U,2),"S",SDI,1,SDII)) D Q:'SDII + ....Q:+$G(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0))'=DFN + ....S SDADM=$P(^SC(+$P(SDA0,U,2),"S",SDI,1,+SDII,0),U,7) + ....S SDADME=$$FMTE^XLFDT(SDADM),SDII=0 + ....Q + ...S SDCZ=SDCP_U_$P($$SITE^VASITE(,$P(SDC0,U,15)),U,2)_U_SDADME + ...S SDZA=SDZA_U_$$FMTE^XLFDT(SDI)_U_$P(SDC0,U)_U_SDCZ + ...S SDZA=SDZA_U_$$FMTE^XLFDT(+SDA0)_U_$$FMDIFF^XLFDT(SDI,+SDA0) + ...S SDZA=SDZA_U_$S(SDADM:$$FMDIFF^XLFDT(+SDA0,SDADM),1:"") + ...W !,SDZ,SDZA + ...Q + ..Q + .Q + W:'SDELIM ! Q + ; +CSCEL(SDEL) ;Convert SC elig. to external + Q $S(SDEL=1:"SC 50-100%",SDEL=3:"SC < 50%",1:"") Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW8.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW8.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW8.m (revision 623) @@ -1,144 +1,133 @@ -SCRPW8 ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99 4:53 PM - ;;5.3;Scheduling;**139,145,144,176,339,466,510**;AUG 13, 1993;Build 3 -QS ;Queue outpatient encounter workload report - D PARM^SCRPW9 Q - ; -PST ;Print stats - N X,Y,% - D NOW^%DTC S Y=% X ^DD("DD") S SDPAGE=1,SDPNOW=$P(Y,":",1,2),SDDT=SDDTF,SDMC=$O(^DG(43,0)),SDMC=$G(^DG(43,+SDMC,"GL")),SDMD=$P(SDMC,U,2),(SDOUT,SDSTOP,SDFF)=0 - S SDDNAM=$P($G(^DG(40.8,+$$PRIM^VASITE(),0)),U,7),SDDNAM=$$GET1^DIQ(4,+SDDNAM,.01) S:'$L(SDDNAM) SDDNAM=$P($G(^DG(40.8,+$P(SDMC,U,3),0)),U) - F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) - F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SDDTL)!SDOUT S SDOE=0 D - .F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,11),$P(SDOE0,U,12) S SDDIV=$$DIV(),SDCG=$$CLGR() D COUNT - .Q - I '$D(^TMP("SCRPW",$J)) D XHDR S SDX="No activity found within the parameters specified." W !!?(80-$L(SDX)\2),SDX G EXIT - F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D STCT - G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 - F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D PRPT - G:SDOUT EXIT - D:SDZ(0) DPRT^SCRPW9("SCRPW",SDDNAM) G:SDOUT EXIT D:SDUL UNARL^SCRPW9("SCRPW",SDDNAM) G EXIT - ; -STCT S (SDUNCO,SDCT,DFN)=0 D STOP Q:SDOUT - F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) Q:'DFN S SDUNCO=SDUNCO+1,SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) Q:'SDDT S SDCT=SDCT+1 - S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO")=SDUNCO,^TMP(SDS1,$J,SDS2,"VISIT","OWK")=SDCT,(SDUNAR,SDCT,DFN)=0 - S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)) Q:'DFN D NCT1 - S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN)) Q:'DFN D CT1 - S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR")=SDUNAR,^TMP(SDS1,$J,SDS2,"VISIT","NWK")=SDCT Q - ; -PRPT ;Print statistics page - D STOP Q:SDOUT - S SDCT=0 F SDI=1,2,3,11,14,"8-CC" S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) - D XHDR Q:SDOUT D SHDR("O U T P A T I E N T E N C O U N T E R W O R K L O A D") Q:SDOUT F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT - I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"CHECKED OUT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT - I $D(^TMP(SDS1,$J,SDS2,"8-CC")) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"INPATIENT APPOINTMENT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,"8-CC",SDI,"")) D IAP - D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,"8-NC",9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) - W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT F SDI="8-NC",12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT - D TOT W !! D SHDR(($$HD2()_" O U T P A T I E N T V I S I T S")) Q:SDOUT S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK") - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2) - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","OWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","OWK")*100/SDCT)),8,2) - D TOT - W !! D SHDR(($$HD2()_" O U T P A T I E N T U N I Q U E S")) Q:SDOUT - S SDUNCO=^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO"),SDUNAR=^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR"),SDCT=SDUNCO+SDUNAR - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted unique pts.",?47,$J(SDUNAR,12),?62,$J($S(SDCT=0:0,1:SDUNAR*100/SDCT),8,2) - D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted unique pts.",?47,$J(SDUNCO,12),?62,$J($S(SDCT=0:0,1:SDUNCO*100/SDCT),8,2) D TOT - Q - ; -XHDR I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - S SDLINE="",$P(SDLINE,"-",81)="" W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?15,"<*> OUTPATIENT ENCOUNTER WORKLOAD STATISTICS <*>" - I $D(^TMP("SCRPW",$J)) S X=$$HD1() W !?(80-$L(X)\2),X - W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 - Q - ; -EXIT K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE - D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) - K I,SDFF,SDOUT,SDSTOP,SDNCOU D END^SCRPW50 Q - ; -HD1() ;Report subheader 1 - Q $S(SDS1="SCRPW":"For station: ",SDS1="SCRPWD":"For division: ",1:"For clinic group: ")_SDS2 - ; -HD2() ;Report subheader 2 - Q $S(SDS1="SCRPW":"F A C I L I T Y",SDS1="SCRPWD":"D I V I S I O N",1:"C L I N I C G R O U P") - ; -DIV() ;Return division name - N X S X=$P($G(^DG(40.8,+$P(SDOE0,U,11),0)),U) Q $S('$L(X):"***UNKNOWN***",1:X) - ; -CLGR() ;Return CLINIC GROUP pointer - N X S X=$P($G(^SC(+$P(SDOE0,U,4),0)),U,31),X=$P($G(^SD(409.67,+X,0)),U) Q $S('$L(X):"***NONE ASSIGNED***",1:X) - ; -NCT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("OWK") - S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 - Q - ; -CT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("NWK") - S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 - Q - ; -UL(SDI) D ^VADPT S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT",SDI,DFN,SDDT)) Q:'SDDT S ^TMP(SDS1,$J,SDS2,"VISIT","UNARL",VADM(1),DFN,$P(VADM(2),U),SDDT)="" - Q - ; -TOT W !?47,"============ =========",!?39,"TOTAL:",?47,$J(SDCT,12),?64,"100.00" Q - ; -SHDR(SDTX) D:$Y>(IOSL-6) XHDR Q:SDOUT W !!?(80-$L(SDTX)\2),SDTX,!?(80-$L(SDTX)\2) F SDX=1:1:$L(SDTX) W "-" - W !!?39,"Status",?54,"Count",?63,"Percent",!?10,"----------------------------------- ------------ ---------" Q - ; -LIST(SDI) Q:'$D(^TMP(SDS1,$J,SDS2,SDI)) D:$Y>(IOSL-4) XHDR Q:SDOUT - W !?10,$P(^SD(409.63,+SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2) - Q - ; -COT D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q - ; -IAP D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"8-CC",SDI,SDSTAT)*100/SDCT)),8,2) Q -STOP ;Check for stop task request - S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -COUNT ;Count encounters - S SDNCOU=$P($G(^SC(+$P(SDOE0,U,4),0)),U,17),SDNCOU=$S(SDNCOU="Y":1,1:0) - S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT - D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q - ; -C1(SDS1,SDS2) ;Set ^TMP global - ;Required input: SDS1,SDS2=subscript values - ;Because there is only 1 status (8) for INPATIENTS, 8-NC is used to - ;distinguish the non-count clinics from the count clinics, 8-CC. - S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDSTAT=8 S SDSTAT=$S(SDNCOU:SDSTAT_"-NC",1:SDSTAT_"-CC") - I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL - S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1 - Q:SDSTAT=4 Q:(+SDSTAT=8)&($P(SDSTAT,"-",2)="NC") D:"114238"[+SDSTAT VIS Q - ; -VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",(+SDSTAT=8)&('SDNCOU):"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(+SDSTAT'=2)&(+SDSTAT'=8) - I +SDSTAT=8,$P(SDOE0,U,7)="" D Q - .S ^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required")=$G(^TMP(SDS1,$J,SDS2,SDSTAT,10,"Action Required"))+1 - S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1 - Q:$P(SDSTX,U)'=8 S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))="" - Q - ; -STX(SDOE,SDOE0) ;Determine transmission status - ;Required input: SDOE=OUTPATIENT ENCOUNTER record IFN - ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER - N SDTOE,SDTOEE - Q:($P(SDOE0,U,12)'=2)&($P(SDOE0,U,12)'=8) "0^Not checked-out^Not checked-out" - S SDTOE=$O(^SD(409.73,"AENC",SDOE,0)) Q:'SDTOE!'$D(^SD(409.73,+SDTOE,0)) "1^No transmission record^No tx. record" - S SDTOE1=$G(^SD(409.73,SDTOE,1)),SDTOE0=^SD(409.73,SDTOE,0) I '$P(SDTOE0,U,4),'$P(SDTOE1,U) Q "2^Not required, not transmitted^Not req., not tx." - ; SD*5.3*339 added second I SDTOEE below - S SDTOEE=$O(^SD(409.75,"B",SDTOE,0)) I SDTOEE S SDTOEE=$P($G(^SD(409.75,SDTOEE,0)),U,2) I SDTOEE S SDTOEE=$P($G(^SD(409.76,SDTOEE,0)),U,2) Q:SDTOEE="V" "3^Rejected for transmission^Rejected for tx." - Q:'$P(SDTOE1,U) "4^Awaiting transmission^Awaiting tx." - S SDTXS=$P(SDTOE1,U,5) Q:'$L(SDTXS) "5^Transmitted, no acknowledgment^Tx., no ack." - Q:SDTXS="R" "6^Transmitted, rejected^Tx., rejected" - Q:SDTXS'="A" "7^Transmitted, error^Tx., error" - Q "8^Transmitted, accepted^Tx., accepted" - ; -DETAIL ;Set global for detailed list - N SDIF S SDIF=0 - D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U) - I SDZ(1)="U",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q - I SDZ(1)="V",+SDSTAT'=4,'SDNCOU S:"114238"[+SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q - Q:'$D(SDZ(2)) ; SD*5.3*339 - I SDZ(2)'=2,SDZ(2)=+SDSTAT D I SDIF Q - .I (SDZ(2)=8) Q:$P(SDSTAT,"-",2)="CC" I SDZ(3)'=9 S SDIF=1 Q - .D DSET S SDIF=1 - Q:("28"'[SDZ(2))!("28"'[+SDSTAT) Q:SDZ(2)'=+SDSTAT D I SDIF Q - .I +SDSTAT=8,$P(SDSTAT,"-",2)="NC" S SDIF=1 Q - .I 'SDZ(3) D DSET S SDIF=1 - D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q - ; -DSET S ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)=+$P(SDOE0,U,4) Q +SCRPW8 ;RENO/KEITH - Outpatient Encounter Workload Statistics ; 04 Feb 99 4:53 PM + ;;5.3;Scheduling;**139,145,144,176,339,466**;AUG 13, 1993;Build 2 +QS ;Queue outpatient encounter workload report + D PARM^SCRPW9 Q + ; +PST ;Print stats + N X,Y,% + D NOW^%DTC S Y=% X ^DD("DD") S SDPAGE=1,SDPNOW=$P(Y,":",1,2),SDDT=SDDTF,SDMC=$O(^DG(43,0)),SDMC=$G(^DG(43,+SDMC,"GL")),SDMD=$P(SDMC,U,2),(SDOUT,SDSTOP,SDFF)=0 + S SDDNAM=$P($G(^DG(40.8,+$$PRIM^VASITE(),0)),U,7),SDDNAM=$$GET1^DIQ(4,+SDDNAM,.01) S:'$L(SDDNAM) SDDNAM=$P($G(^DG(40.8,+$P(SDMC,U,3),0)),U) + F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) + F S SDDT=$O(^SCE("B",SDDT)) Q:'SDDT!(SDDT>SDDTL)!SDOUT S SDOE=0 D + .F S SDOE=$O(^SCE("B",SDDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,11),$P(SDOE0,U,12) S SDDIV=$$DIV(),SDCG=$$CLGR() D COUNT + .Q + I '$D(^TMP("SCRPW",$J)) D XHDR S SDX="No activity found within the parameters specified." W !!?(80-$L(SDX)\2),SDX G EXIT + F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D STCT + G:SDOUT EXIT D:$E(IOST)="C" DISP0^SCRPW23 + F SDS1="SCRPW","SCRPWD","SCRPWC" S SDS2="" F S SDS2=$O(^TMP(SDS1,$J,SDS2)) Q:SDS2=""!SDOUT D PRPT + G:SDOUT EXIT + D:SDZ(0) DPRT^SCRPW9("SCRPW",SDDNAM) G:SDOUT EXIT D:SDUL UNARL^SCRPW9("SCRPW",SDDNAM) G EXIT + ; +STCT S (SDUNCO,SDCT,DFN)=0 D STOP Q:SDOUT + F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) Q:'DFN S SDUNCO=SDUNCO+1,SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) Q:'SDDT S SDCT=SDCT+1 + S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO")=SDUNCO,^TMP(SDS1,$J,SDS2,"VISIT","OWK")=SDCT,(SDUNAR,SDCT,DFN)=0 + S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)) Q:'DFN D NCT1 + S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN)) Q:'DFN D CT1 + S ^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR")=SDUNAR,^TMP(SDS1,$J,SDS2,"VISIT","NWK")=SDCT Q + ; +PRPT ;Print statistics page + D STOP Q:SDOUT + S SDCT=0 F SDI=1,2,3,11,14,8 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) + D XHDR Q:SDOUT D SHDR("O U T P A T I E N T E N C O U N T E R W O R K L O A D") Q:SDOUT F SDI=11,14,3,1 D LIST(SDI) Q:SDOUT + I $D(^TMP(SDS1,$J,SDS2,2)) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"CHECKED OUT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,2,SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,2,SDI,"")) D COT + I $D(^TMP(SDS1,$J,SDS2,8)) D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"INPATIENT APPOINTMENT" S SDI=0 F S SDI=$O(^TMP(SDS1,$J,SDS2,8,SDI)) Q:'SDI!SDOUT S SDSTAT=$O(^TMP(SDS1,$J,SDS2,8,SDI,"")) D IAP + D TOT S (SDI,SDCT)=0 F SDI=4,5,6,7,9,12,13 S SDCT=SDCT+$G(^TMP(SDS1,$J,SDS2,SDI)) + W !! D SHDR("N O N - W O R K L O A D") Q:SDOUT F SDI=12,4,6,5,7,9,10,13 D LIST(SDI) Q:SDOUT + D TOT W !! D SHDR(($$HD2()_" O U T P A T I E N T V I S I T S")) Q:SDOUT S SDCT=^TMP(SDS1,$J,SDS2,"VISIT","NWK")+^TMP(SDS1,$J,SDS2,"VISIT","OWK") + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","NWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","NWK")*100/SDCT)),8,2) + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted visits",?47,$J(^TMP(SDS1,$J,SDS2,"VISIT","OWK"),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,"VISIT","OWK")*100/SDCT)),8,2) + D TOT + W !! D SHDR(($$HD2()_" O U T P A T I E N T U N I Q U E S")) Q:SDOUT + S SDUNCO=^TMP(SDS1,$J,SDS2,"UNIQUE","UNCO"),SDUNAR=^TMP(SDS1,$J,SDS2,"UNIQUE","UNAR"),SDCT=SDUNCO+SDUNAR + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Act. Req./not accepted unique pts.",?47,$J(SDUNAR,12),?62,$J($S(SDCT=0:0,1:SDUNAR*100/SDCT),8,2) + D:$Y>(IOSL-4) XHDR Q:SDOUT W !?10,"Transmitted, accepted unique pts.",?47,$J(SDUNCO,12),?62,$J($S(SDCT=0:0,1:SDUNCO*100/SDCT),8,2) D TOT + Q + ; +XHDR I $E(IOST)="C",SDPAGE>1 N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + S SDLINE="",$P(SDLINE,"-",81)="" W:SDPAGE>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) W SDLINE,!?15,"<*> OUTPATIENT ENCOUNTER WORKLOAD STATISTICS <*>" + I $D(^TMP("SCRPW",$J)) S X=$$HD1() W !?(80-$L(X)\2),X + W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 + Q + ; +EXIT K SDTOE0,SDUNCO,SDUNAR,SDCT,DFN,SDDT,SDDTF,SDDTL,SDDTPF,SDDTPL,SDI,SDLINE,SDOE,SDOE0,SDPNOW,SDSTAT,SDSTX,SDTOE,SDTOEE,SDTOE1,SDTX,SDTXS,SDX,SDZ,DTOUT,X,Y,ZTDESC,ZTRTN,ZTSAVE + D KVA^VADPT K X1,X2,SDH,SDHL,SDPNAM,SDSSN,SDPAGE,SDPT0,SDUL,DUOUT,SDARCT,SDST,SDPNOW,SDMD,SDMC,SDDIV,SDDNAM,SDS1,SDS2,SDCG,SDCLGR F I="SCRPW","SCRPWD","SCRPWC" K ^TMP(I,$J) + K I,SDFF,SDOUT,SDSTOP D END^SCRPW50 Q + ; +HD1() ;Report subheader 1 + Q $S(SDS1="SCRPW":"For station: ",SDS1="SCRPWD":"For division: ",1:"For clinic group: ")_SDS2 + ; +HD2() ;Report subheader 2 + Q $S(SDS1="SCRPW":"F A C I L I T Y",SDS1="SCRPWD":"D I V I S I O N",1:"C L I N I C G R O U P") + ; +DIV() ;Return division name + N X S X=$P($G(^DG(40.8,+$P(SDOE0,U,11),0)),U) Q $S('$L(X):"***UNKNOWN***",1:X) + ; +CLGR() ;Return CLINIC GROUP pointer + N X S X=$P($G(^SC(+$P(SDOE0,U,4),0)),U,31),X=$P($G(^SD(409.67,+X,0)),U) Q $S('$L(X):"***NONE ASSIGNED***",1:X) + ; +NCT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("OWK") + S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 + Q + ; +CT1 I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN)) S SDUNAR=SDUNAR+1 D:SDUL&(SDS1="SCRPW") UL("NWK") + S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","NWK",DFN,SDDT)) Q:'SDDT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","OWK",DFN,SDDT)),'$D(^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,SDDT)) S SDCT=SDCT+1 + Q + ; +UL(SDI) D ^VADPT S SDDT=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT",SDI,DFN,SDDT)) Q:'SDDT S ^TMP(SDS1,$J,SDS2,"VISIT","UNARL",VADM(1),DFN,$P(VADM(2),U),SDDT)="" + Q + ; +TOT W !?47,"============ =========",!?39,"TOTAL:",?47,$J(SDCT,12),?64,"100.00" Q + ; +SHDR(SDTX) D:$Y>(IOSL-6) XHDR Q:SDOUT W !!?(80-$L(SDTX)\2),SDTX,!?(80-$L(SDTX)\2) F SDX=1:1:$L(SDTX) W "-" + W !!?39,"Status",?54,"Count",?63,"Percent",!?10,"----------------------------------- ------------ ---------" Q + ; +LIST(SDI) Q:'$D(^TMP(SDS1,$J,SDS2,SDI)) D:$Y>(IOSL-4) XHDR Q:SDOUT + W !?10,$P(^SD(409.63,SDI,0),U),?47,$J(^TMP(SDS1,$J,SDS2,SDI),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,SDI)*100/SDCT)),8,2) + Q + ; +COT D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,2,SDI,SDSTAT)*100/SDCT)),8,2) Q + ; +IAP D:$Y>(IOSL-4) XHDR Q:SDOUT W !?15,SDSTAT,?47,$J(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT),12),?62,$J($S(SDCT=0:0,1:(^TMP(SDS1,$J,SDS2,8,SDI,SDSTAT)*100/SDCT)),8,2) Q +STOP ;Check for stop task request + S:$G(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +COUNT ;Count encounters + S SDSTOP=SDSTOP+1 I SDSTOP#3000=0 D STOP Q:SDOUT + D C1("SCRPW",SDDNAM) D:SDMD C1("SCRPWD",SDDIV) D:SDCLGR C1("SCRPWC",SDCG) Q + ; +C1(SDS1,SDS2) ;Set ^TMP global + ;Required input: SDS1,SDS2=subscript values + S DFN=$P(SDOE0,U,2),SDSTAT=+$P(SDOE0,U,12) I SDZ(0),SDZ(4)=SDDIV,SDS1="SCRPW" D DETAIL + S ^TMP(SDS1,$J,SDS2,SDSTAT)=$G(^TMP(SDS1,$J,SDS2,SDSTAT))+1 + Q:SDSTAT=4 D:"114238"[SDSTAT VIS Q + ; +VIS S ^TMP(SDS1,$J,SDS2,"VISIT",$S(SDSTAT=2:"OWK",SDSTAT=8:"OWK",1:"NWK"),DFN,$P(SDDT,"."))="" Q:(SDSTAT'=2)&(SDSTAT'=8) + S SDSTX=$$STX(SDOE,SDOE0),^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2))=$G(^TMP(SDS1,$J,SDS2,SDSTAT,$P(SDSTX,U),$P(SDSTX,U,2)))+1 + Q:$P(SDSTX,U)'=8 S ^TMP(SDS1,$J,SDS2,"VISIT","ACC",DFN,$P(SDDT,"."))="" + Q + ; +STX(SDOE,SDOE0) ;Determine transmission status + ;Required input: SDOE=OUTPATIENT ENCOUNTER record IFN + ;Required input: SDOE0=zeroeth node of OUTPATIENT ENCOUNTER + N SDTOE,SDTOEE + Q:($P(SDOE0,U,12)'=2)&($P(SDOE0,U,12)'=8) "0^Not checked-out^Not checked-out" + S SDTOE=$O(^SD(409.73,"AENC",SDOE,0)) Q:'SDTOE!'$D(^SD(409.73,+SDTOE,0)) "1^No transmission record^No tx. record" + S SDTOE1=$G(^SD(409.73,SDTOE,1)),SDTOE0=^SD(409.73,SDTOE,0) I '$P(SDTOE0,U,4),'$P(SDTOE1,U) Q "2^Not required, not transmitted^Not req., not tx." + ; SD*5.3*339 added second I SDTOEE below + S SDTOEE=$O(^SD(409.75,"B",SDTOE,0)) I SDTOEE S SDTOEE=$P($G(^SD(409.75,SDTOEE,0)),U,2) I SDTOEE S SDTOEE=$P($G(^SD(409.76,SDTOEE,0)),U,2) Q:SDTOEE="V" "3^Rejected for transmission^Rejected for tx." + Q:'$P(SDTOE1,U) "4^Awaiting transmission^Awaiting tx." + S SDTXS=$P(SDTOE1,U,5) Q:'$L(SDTXS) "5^Transmitted, no acknowledgment^Tx., no ack." + Q:SDTXS="R" "6^Transmitted, rejected^Tx., rejected" + Q:SDTXS'="A" "7^Transmitted, error^Tx., error" + Q "8^Transmitted, accepted^Tx., accepted" + ; +DETAIL ;Set global for detailed list + D ^VADPT S SDPNAM=VADM(1),SDSSN=$P(VADM(2),U) + I SDZ(1)="U",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN)="" Q + I SDZ(1)="V",SDSTAT'=4 S:"114238"[SDSTAT ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,$P(SDDT,"."))="" Q + Q:'$D(SDZ(2)) ; SD*5.3*339 + I (SDZ(2)'=2)&(SDZ(2)'=8),SDZ(2)=SDSTAT D DSET Q + Q:("28"'[SDZ(2))!("28"'[SDSTAT)!(SDZ(2)'=SDSTAT) I 'SDZ(3) D DSET Q + D:+$$STX(SDOE,SDOE0)=SDZ(3) DSET Q + ; +DSET S ^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)=+$P(SDOE0,U,4) Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW9.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW9.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SCRPW9.m (revision 623) @@ -1,107 +1,105 @@ -SCRPW9 ;RENO/KEITH - Outpatient Encounter Workload Statistics (cont.) ; 15 Jul 98 02:38PM - ;;5.3;Scheduling;**139,144,339,466,510**;AUG 13, 1993;Build 3 -UNARL(SDS1,SDS2) ;Print list of 'action required'/not accepted uniques - ;Required input: SDS1,SDS2=subscript values - S SDPAGE=1 D UHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) W !!,"No 'action required'/not accepted unique patients identified." Q - S SDARCT=0,SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN)) Q:'DFN!SDOUT D UNP - Q:SDOUT D:$Y>(IOSL-3) UHDR Q:SDOUT W !!,SDARCT," 'action required'/not accepted unique patient",$S(SDARCT=1:"",1:"s")," identified." Q - ; -UNP S SDSSN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) UHDR Q:SDOUT W !,$E(SDPNAM,1,18),?20,SDSSN - S SDARCT=SDARCT+1,(SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D:$Y>(IOSL-4) UHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?31,Y S SDI=1 D UNP1 - Q - ; -UNP1 N SDII,SDDT1 S SDII=0,SDDT1=SDDT F S SDDT1=$O(^SCE("ADFN",DFN,SDDT1)) Q:'SDDT1!(SDDT1>(SDDT+.9999))!SDOUT D - .S SDOE=0 F S SDOE=$O(^SCE("ADFN",DFN,SDDT1,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6) D UNP2 - .Q - Q - ; -UNP2 N SDCL,SDST Q:'$P(SDOE0,U,4) S SDCL=$P($G(^SC($P(SDOE0,U,4),0)),U),SDST=$P(SDOE0,U,12) Q:$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q:'SDST!(SDST=12) S SDST=$S("28"'[SDST:$P(^SD(409.63,SDST,0),U),1:$P($$STX^SCRPW8(SDOE,SDOE0),U,3)) - D:$Y>(IOSL-4) UHDR Q:SDOUT W:SDII ! W ?44,$E(SDCL,1,17),?63,$E(SDST,1,17) S SDII=SDII+1 Q - ; -UHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - D STOP^SCRPW8 Q:SDOUT - W $$XY^SCRPW50(IOF,1,0),SDLINE,!?8,"<*> LIST OF 'ACTION REQUIRED'/NOT ACCEPTED UNIQUE PATIENTS <*>",!?(66-$L(SDDNAM)\2),"For station: ",SDDNAM - W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 - W:$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) !,"Name:",?20,"SSN:",?31,"Date:",?44,"Location:",?63,"Reason:",! Q - ; -DETAIL ;Ask questions for detail of encounters or uniques for a division - K SDZ S SDZ(0)=0 K DIR S DIR(0)="Y",DIR("A")="Would you like to print a detailed list of activity for a division",DIR("B")="NO" W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q - S SDZ(0)=Y Q:'Y W !!!,$C(7)," WARNING: Selection high activity areas will result in lengthy output!",! - K DIR S DIR(0)="S^U:UNIQUES;V:VISITS;E:ENCOUNTERS",DIR("A")="Select type of list" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q - S SDZ(1)=Y G:Y'="E" ZDIV -DET1 K DIC S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDZ(0)=-1 Q - S SDZ(2)=$P(Y,U) G:(SDZ(2)'=2)&(SDZ(2)'=8) ZDIV K DIR S DIR("A")="Select transmission status for "_$S(SDZ(2)=2:"CHECKED OUT",1:"INPATIENT APPOINTMENT")_" encounters" - S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;" - S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted" - I SDZ(2)=8 S DIR(0)=DIR(0)_";9:Non-Count (not transmitted)" - W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q ;SD*5.3*339 add sub-zero - S SDZ(3)=+Y -ZDIV ;Get division for detail - I '$P($G(^DG(43,1,"GL")),U,2) S SDZ(4)=$P(^DG(40.8,$$PRIM^VASITE(),0),U) Q - K DIC S DIC="^DG(40.8,",DIC("A")="Select Medical Center division for detail: ",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q - I Y<1 W $C(7)," Required for patient detail!" G ZDIV - S SDZ(4)=$P(Y,U,2) Q - ; -DPRT(SDS1,SDS2) ;Detail print - ;Required input: SDS1,SDS2=subscript values - K SDH S SDPAGE=1,SDH(1)="<*> DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_" <*>",SDH(2)="For division: "_SDZ(4) - I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status" - I $G(SDZ(2))'="","28"[SDZ(2) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2) - D DHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q - S SDCT=0 D @SDZ(1) Q - ; -U ;Print uniques - S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT D U1 - Q:SDOUT W !!,SDCT," uniques identified." Q - ; -U1 S SDCT=SDCT+1,SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN Q - ; -V ;Print visits - S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D V1 - Q:SDOUT W !!,SDCT," visits identified." Q - ; -V1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D - .D:$Y>(IOSL-3) DHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?32,Y S SDCT=SDCT+1,SDI=SDI+1 - .Q - Q - ; -E ;Print encounters - S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D E1 - Q:SDOUT W !!,SDCT," encounters identified." Q - ; -E1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN - S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT S SDOE=0 F S SDOE=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)) Q:'SDOE!SDOUT D E2 - Q - ; -E2 D:$Y>(IOSL-3) DHDR Q:SDOUT S SDHL=^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE),SDHL=$P($G(^SC(+SDHL,0)),U),Y=SDDT X ^DD("DD") W:SDI ! W ?32,$P(Y,":",1,2),?50,SDHL S SDCT=SDCT+1,SDI=SDI+1 Q - ; -DHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT - D STOP^SCRPW8 Q:SDOUT - W $$XY^SCRPW50(IOF,1,0),SDLINE S I=0 F S I=$O(SDH(I)) Q:'I W !?(80-$L(SDH(I))\2),SDH(I) - W !,SDLINE,!,"For date range: ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 Q - ; -TXS ;All transmission statuses - ;No transmission record - ;Not required, not transmitted - ;Rejected for transmission - ;Awaiting transmission - ;Transmitted, no acknowledgment - ;Transmitted, rejected - ;Transmitted, error - ;Transmitted, accepted - ;Non-Count (not transmitted) - ; -PARM ;Prompt for report parameters - D TITL^SCRPW50("Outpatient Encounter Workload Statistics") - N %DT,DIR,DIC D SUBT^SCRPW50("*** Date Range Selection ***") -FDT W ! S %DT="AEPX",%DT("A")="Beginning date: FIRST// ",%DT(0)=2961001 D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S (Y,SDDTF)=2961001 X ^DD("DD") W " ",Y,! S SDDTPF=Y G LDT - G:Y<1 FDT S SDDTF=Y X ^DD("DD") S SDDTPF=Y W ! -LDT S %DT("A")="Ending date: LAST// " D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S X1=DT,X2=-1 D C^%DTC S (Y,SDDTL)=X X ^DD("DD") W " ",Y,! S SDDTPL=Y G ASK - I Y(IOSL-3) UHDR Q:SDOUT W !!,SDARCT," 'action required'/not accepted unique patient",$S(SDARCT=1:"",1:"s")," identified." Q + ; +UNP S SDSSN=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) UHDR Q:SDOUT W !,$E(SDPNAM,1,18),?20,SDSSN + S SDARCT=SDARCT+1,(SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"VISIT","UNARL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D:$Y>(IOSL-4) UHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?31,Y S SDI=1 D UNP1 + Q + ; +UNP1 N SDII,SDDT1 S SDII=0,SDDT1=SDDT F S SDDT1=$O(^SCE("ADFN",DFN,SDDT1)) Q:'SDDT1!(SDDT1>(SDDT+.9999))!SDOUT D + .S SDOE=0 F S SDOE=$O(^SCE("ADFN",DFN,SDDT1,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I $L(SDOE0),'$P(SDOE0,U,6) D UNP2 + .Q + Q + ; +UNP2 N SDCL,SDST Q:'$P(SDOE0,U,4) S SDCL=$P($G(^SC($P(SDOE0,U,4),0)),U),SDST=$P(SDOE0,U,12) Q:$P($G(^SC($P(SDOE0,U,4),0)),U,17)="Y" Q:'SDST!(SDST=12) S SDST=$S("28"'[SDST:$P(^SD(409.63,SDST,0),U),1:$P($$STX^SCRPW8(SDOE,SDOE0),U,3)) + D:$Y>(IOSL-4) UHDR Q:SDOUT W:SDII ! W ?44,$E(SDCL,1,17),?63,$E(SDST,1,17) S SDII=SDII+1 Q + ; +UHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + D STOP^SCRPW8 Q:SDOUT + W $$XY^SCRPW50(IOF,1,0),SDLINE,!?8,"<*> LIST OF 'ACTION REQUIRED'/NOT ACCEPTED UNIQUE PATIENTS <*>",!?(66-$L(SDDNAM)\2),"For station: ",SDDNAM + W !,SDLINE,!,"For encounter dates ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 + W:$D(^TMP(SDS1,$J,SDS2,"VISIT","UNARL")) !,"Name:",?20,"SSN:",?31,"Date:",?44,"Location:",?63,"Reason:",! Q + ; +DETAIL ;Ask questions for detail of encounters or uniques for a division + K SDZ S SDZ(0)=0 K DIR S DIR(0)="Y",DIR("A")="Would you like to print a detailed list of activity for a division",DIR("B")="NO" W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q + S SDZ(0)=Y Q:'Y W !!!,$C(7)," WARNING: Selection high activity areas will result in lengthy output!",! + K DIR S DIR(0)="S^U:UNIQUES;V:VISITS;E:ENCOUNTERS",DIR("A")="Select type of list" D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q + S SDZ(1)=Y G:Y'="E" ZDIV +DET1 K DIC S DIC="^SD(409.63,",DIC(0)="AEMQ",DIC("S")="I Y<4!(Y=8!(Y=12!(Y=14)))",DIC("A")="Select encounter status: " W ! D ^DIC I $D(DTOUT)!$D(DUOUT)!($G(Y)<1) S SDZ(0)=-1 Q + S SDZ(2)=$P(Y,U) G:(SDZ(2)'=2)&(SDZ(2)'=8) ZDIV K DIR S DIR("A")="Select transmission status for "_$S(SDZ(2)=2:"CHECKED OUT",1:"INPATIENT APPOINTMENT")_" encounters" + S DIR(0)="S^A:All transmission statuses;1:No transmission record;2:Not required, not transmitted;3:Rejected for transmission;4:Awaiting transmission;" + S DIR(0)=DIR(0)_"5:Transmitted, no acknowledgment;6:Transmitted, rejected;7:Transmitted, error;8:Transmitted, accepted" + W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q ;SD*5.3*339 add sub-zero + S SDZ(3)=+Y +ZDIV ;Get division for detail + I '$P($G(^DG(43,1,"GL")),U,2) S SDZ(4)=$P(^DG(40.8,$$PRIM^VASITE(),0),U) Q + K DIC S DIC="^DG(40.8,",DIC("A")="Select Medical Center division for detail: ",DIC(0)="AEMQ" W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SDZ(0)=-1 Q + I Y<1 W $C(7)," Required for patient detail!" G ZDIV + S SDZ(4)=$P(Y,U,2) Q + ; +DPRT(SDS1,SDS2) ;Detail print + ;Required input: SDS1,SDS2=subscript values + K SDH S SDPAGE=1,SDH(1)="<*> DETAILED LIST OF DIVISION "_$S(SDZ(1)="U":"UNIQUES",SDZ(1)="V":"VISITS",1:"ENCOUNTERS")_" <*>",SDH(2)="For division: "_SDZ(4) + I $G(SDZ(2)) S SDH(3)="Encounters with "_$P(^SD(409.63,SDZ(2),0),U)_" status" + I "28"[$G(SDZ(2)) S SDH(4)="Transmission status: "_$P($T(TXS+SDZ(3)),";",2) + D DHDR Q:SDOUT I '$D(^TMP(SDS1,$J,SDS2,"DETAIL")) W !,"No records found in this category." Q + S SDCT=0 D @SDZ(1) Q + ; +U ;Print uniques + S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT D U1 + Q:SDOUT W !!,SDCT," uniques identified." Q + ; +U1 S SDCT=SDCT+1,SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN Q + ; +V ;Print visits + S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D V1 + Q:SDOUT W !!,SDCT," visits identified." Q + ; +V1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT D + .D:$Y>(IOSL-3) DHDR Q:SDOUT S Y=SDDT X ^DD("DD") W:SDI ! W ?32,Y S SDCT=SDCT+1,SDI=SDI+1 + .Q + Q + ; +E ;Print encounters + S SDPNAM="" F S SDPNAM=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM)) Q:SDPNAM=""!SDOUT S DFN=0 F S DFN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN)) Q:'DFN!SDOUT S SDSSN=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,"")) D E1 + Q:SDOUT W !!,SDCT," encounters identified." Q + ; +E1 D:$Y>(IOSL-4) DHDR Q:SDOUT W !,$E(SDPNAM,1,18),?21,SDSSN + S (SDDT,SDI)=0 F S SDDT=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT)) Q:'SDDT!SDOUT S SDOE=0 F S SDOE=$O(^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE)) Q:'SDOE!SDOUT D E2 + Q + ; +E2 D:$Y>(IOSL-3) DHDR Q:SDOUT S SDHL=^TMP(SDS1,$J,SDS2,"DETAIL",SDPNAM,DFN,SDSSN,SDDT,SDOE),SDHL=$P($G(^SC(+SDHL,0)),U),Y=SDDT X ^DD("DD") W:SDI ! W ?32,$P(Y,":",1,2),?50,SDHL S SDCT=SDCT+1,SDI=SDI+1 Q + ; +DHDR I $E(IOST)="C" N DIR S DIR(0)="E" D ^DIR S SDOUT=Y'=1 Q:SDOUT + D STOP^SCRPW8 Q:SDOUT + W $$XY^SCRPW50(IOF,1,0),SDLINE S I=0 F S I=$O(SDH(I)) Q:'I W !?(80-$L(SDH(I))\2),SDH(I) + W !,SDLINE,!,"For date range: ",SDDTPF," to ",SDDTPL,!,"Date printed: ",SDPNOW,?(74-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE,! S SDPAGE=SDPAGE+1 Q + ; +TXS ;All transmission statuses + ;No transmission record + ;Not required, not transmitted + ;Rejected for transmission + ;Awaiting transmission + ;Transmitted, no acknowledgment + ;Transmitted, rejected + ;Transmitted, error + ;Transmitted, accepted + ; +PARM ;Prompt for report parameters + D TITL^SCRPW50("Outpatient Encounter Workload Statistics") + N %DT,DIR,DIC D SUBT^SCRPW50("*** Date Range Selection ***") +FDT W ! S %DT="AEPX",%DT("A")="Beginning date: FIRST// ",%DT(0)=2961001 D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S (Y,SDDTF)=2961001 X ^DD("DD") W " ",Y,! S SDDTPF=Y G LDT + G:Y<1 FDT S SDDTF=Y X ^DD("DD") S SDDTPF=Y W ! +LDT S %DT("A")="Ending date: LAST// " D ^%DT G:X=U!$D(DTOUT) EXIT^SCRPW8 I X="" S X1=DT,X2=-1 D C^%DTC S (Y,SDDTL)=X X ^DD("DD") W " ",Y,! S SDDTPL=Y G ASK + I Y0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N - S SDCOPY=M - ; -- specify device - W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP - S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END - I $D(IO("Q")) D QUE W:$D(ZTSK) " (Task#: ",ZTSK,")" G END - ; -START U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0 - ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS - F S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0 D - .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7) - S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL - S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1) - D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2) - I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF)) - S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD - ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC - I VAUTC=1 S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0 D - . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D - .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN - ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------ - K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT - S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21" - ;if user has selected clinics, build clinic filter list - I VAUTC'=1 D I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end - . S SD="" F S SD=$O(VAUTC(SD)) Q:SD']"" S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";" - ;call SDAPI to retrieve appointment data - S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY) - ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL - ;if error returned from SDAPI, display on report and quit - I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q - ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient - I SDRESULT>0 D - . S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL D - .. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN D - ... S SDDT=0 F S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT D - .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT) - ;--------------------------------------------------------------------------- -LOOPA ;S SD=0 F S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND D CLIN - ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name) - I SDRESULT'<0 S SD=0 F S SD=$O(VAUTC(SD)) Q:SD']""!SDEND D CLIN - G:SDEND END -OVER ;S PCNT=PCNT+1 I PCNT0!SDEND I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0 - ;process each clinic IEN from VAUTC array - S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0 - Q - ; -BARQ(TTYPE,MARGIN) ; - N ON,OFF,Y - I MARGIN<120 S Y=0 G BARCQ - I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ - S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)" - D ^DIR K DIR S:$D(DIRUT) Y="^" -BARCQ Q Y - ; -QUE ;Queue output - N ZTDESC,ZTSAVE,ZTRTN - K ZTSK,IO("Q") - S ZTDESC="Appointment Lists",ZTRTN="START^SDAL" - F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)="" - D ^%ZTLOAD - Q - ; -STOP ;Check for stop task request - S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q - ; -HED ;Print report header - I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND - D STOP Q:SDEND - S SDCOUNT=SDCOUNT+1,SD1=1 - W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) - W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD - W:'SC "Appointments for ",SDPD - W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,! - W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG" - ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" - W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" - W !,SDASH S SDPAGE=SDPAGE+1 - D:SDBC PAINT(SC,SDD) - Q - ; -PAINT(CLINIC,DATE) ; -- paint header barcodes - ; input: CLINIC := clinic ifn - ; DATE := appt date only - ; - W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",! - D BARC(10,$E(DATE,4,7)_$E(DATE,2,3)) - D BARC(45,"%"_CLINIC_"$") - D BARC(85,"N"),BARC(110,"Y") - W !!!!,SDASH - Q - ; -BARC(TAB,X) ; --print barcode - ; input: TAB := tab position - ; X := string to print - ; - W *13,?TAB W @SDBCON,X,@SDBCOFF - Q - ; +SDAL ;ALB/GRR,MJK - APPOINTMENT LIST ; 29 Jun 99 04:11PM + ;;5.3;Scheduling;**37,46,106,171,177,80,266**;Aug 13, 1993 +EN W ! S SDEND=1 D ASK2^SDDIV G:Y<0 END + W ! S VAUTNI=1 D NCOUNT^SDAL0 I SDCONC=U G END + W ! D NCLINIC^SDAL0 G:Y<0 END +RD1 W ! N %DT K DIC("S") S %DT("A")="For date: ",%DT="AEXF" D ^%DT + I (X["^")!(Y<0) K %,VAUTD,VAUTC,X,Y Q + S SDD=Y + N DIR S DIR(0)="Y",DIR("B")="NO" + S DIR("A")="Include Primary Care assignment information in the output" + W ! D ^DIR I $D(DTOUT)!$D(DUOUT) K SDD,VAUTC,VAUTD,X,Y Q + W ! S SDPCMM=Y +N K SDX,SDX1 R !,"Number of copies: 1// ",M:DTIME S:M="" M=1 + I M["^" K M,SDD,VAUTC,VAUTD,X,Y Q + I (M'?.N)!((M'>0)!($L(M)>3)) W !,"ENTER A WHOLE NUMBER TO SELECT THE # OF COPIES OF THE APPOINTMENT LIST THAT ARE NEEDED- (1-999)" G N + S SDCOPY=M + ; -- specify device + W ! N %ZIS K IO("Q") S %ZIS="QMP" D ^%ZIS G END:POP + S SDBC=$$BARQ(+IOST(0),IOM) I SDBC="^" G END + I $D(IO("Q")) D QUE W:$D(ZTSK) " (Task#: ",ZTSK,")" G END + ; +START U IO N CNT,SDCLAR,SDCOUNT S (SDCOUNT,CNT)=0 + ;SET UP A TEMP ARRAY -SDCLAR- WITH CLASSIFICATION ABBREVIATIONS + F S CNT=$O(^SD(409.41,CNT)) Q:CNT'>0 D + .S SDCLAR(CNT)=$P(^SD(409.41,CNT,0),U,7) + S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL + S SDASH="",$P(SDASH,"_",IOM+1)="" S SDBC=+$G(SDBC),SDCOPY=$S($D(SDCOPY):+SDCOPY,$D(M):+M,1:1) + D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2) + I SDBC S SDBC=$S(IOM<120:0,1:$$BARC^SDAMU(+IOST(0),.SDBCON,.SDBCOFF)) + S (SDEND,SD1,PCNT)=0,Y=DT D D^DIQ S SDNT=Y,Y=SDD,X=Y D D^DIQ S SDPD=Y D DW^%DTC S SDPD=X_" "_SDPD + ;if user has selected 'all' clinics, populate VAUTC with all uncancelled TYPE=C clinics from ^SC + I VAUTC=1 S SDIEN=0 F S SDIEN=$O(^SC(SDIEN)) Q:+SDIEN=0 D + . I $P(^SC(SDIEN,0),"^",3)="C",$G(^SC(SDIEN,"ST",SDD,1))'["CANCELLED" D + .. S SDNAME=$P(^SC(SDIEN,0),"^",1) I $G(SDNAME)]"" S VAUTC(SDNAME)=SDIEN + ;-------------CALL TO SDAPI^SDAMA301 TO RETRIEVE APPT DATA------------------ + K ^TMP($J,"SDAMA301") N SDARRAY,SDIEN,SDNAME,SDERR,SDCL,SDDFN,SDDT,SDRESULT + S SDARRAY(1)=SDD_";"_SDD,SDARRAY(3)="I;R;NT",SDARRAY("FLDS")="4;6;7;8;10;19;20;21" + ;if user has selected clinics, build clinic filter list + I VAUTC'=1 D I $L(SDARRAY(2)) S SDARRAY(2)=$E(SDARRAY(2),1,$L(SDARRAY(2))-1) ;remove last ';' from end + . S SD="" F S SD=$O(VAUTC(SD)) Q:SD']"" S SC=$G(VAUTC(SD)) I $G(SC)]"" S SDARRAY(2)=$G(SDARRAY(2))_SC_";" + ;call SDAPI to retrieve appointment data + S SDRESULT=$$SDAPI^SDAMA301(.SDARRAY) + ;I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 D HED W !!,SDERR,! I $E(IOST,1,2)="C-" D OUT^SDUTL + ;if error returned from SDAPI, display on report and quit + I SDRESULT<0 S SDERR=$$SDAPIERR^SDAMUTDT() I $L(SDERR) S SC=0 S SDPAGE=1 D HED W !!,SDERR,! D:$E(IOST,1,2)="C-" OUT^SDUTL D EXIT Q + ;if appts returned from SDAPI, sort output by clinic, appt d/t, patient + I SDRESULT>0 D + . S SDCL=0 F S SDCL=$O(^TMP($J,"SDAMA301",SDCL)) Q:'SDCL D + .. S SDDFN=0 F S SDDFN=$O(^TMP($J,"SDAMA301",SDCL,SDDFN)) Q:'SDDFN D + ... S SDDT=0 F S SDDT=$O(^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT)) Q:'SDDT D + .... M ^TMP($J,"SDAMA301","S",SDCL,SDDT,SDDFN)=^TMP($J,"SDAMA301",SDCL,SDDFN,SDDT) + ;--------------------------------------------------------------------------- +LOOPA ;S SD=0 F S SD=$S(VAUTC:$O(^SC("B",SD)),1:$O(VAUTC(SD))) Q:SD']""!SDEND D CLIN + ;if no error returned from SDAPI, start looping through clinics in VAUTC (sorted by name) + I SDRESULT'<0 S SD=0 F S SD=$O(VAUTC(SD)) Q:SD']""!SDEND D CLIN + G:SDEND END +OVER ;S PCNT=PCNT+1 I PCNT0!SDEND I $D(^SC(SC,0)),$P(^(0),"^",3)="C" I $S(VAUTC:1,'$D(VAUTC(SD)):0,VAUTC(SD)=SC:1,1:0) D LOOP^SDAL0 + ;process each clinic IEN from VAUTC array + S (SDFL,SC)=0 S SC=$G(VAUTC(SD)) I $G(SC)>0,$D(^SC(SC,0)) D LOOP^SDAL0 + Q + ; +BARQ(TTYPE,MARGIN) ; + N ON,OFF,Y + I MARGIN<120 S Y=0 G BARCQ + I '$$BARC^SDAMU(.TTYPE,.ON,.OFF) S Y=0 G BARCQ + S DIR(0)="Y",DIR("B")="NO",DIR("A")="SHOULD BARCODES BE PRINTED ON LIST(S)" + D ^DIR K DIR S:$D(DIRUT) Y="^" +BARCQ Q Y + ; +QUE ;Queue output + N ZTDESC,ZTSAVE,ZTRTN + K ZTSK,IO("Q") + S ZTDESC="Appointment Lists",ZTRTN="START^SDAL" + F X="VAUTD(","VAUTC(","SDCOPY","SDD","SDBC","VAUTD","VAUTC","SDCONC","SDPCMM" S ZTSAVE(X)="" + D ^%ZTLOAD + Q + ; +STOP ;Check for stop task request + S:$D(ZTQUEUED) (SDEND,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q + ; +HED ;Print report header + I SD1,$E(IOST)="C" D OUT^SDUTL Q:SDEND + D STOP Q:SDEND + S SDCOUNT=SDCOUNT+1,SD1=1 + W:SDCOUNT>1!($E(IOST)="C") $$XY^SCRPW50(IOF,1,0) W:$X $$XY^SCRPW50("",0,0) + W:SC "Appointments for ",$P(^SC(SC,0),"^",1)," clinic on ",SDPD + W:'SC "Appointments for ",SDPD + W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,! + W !," Appt.",?11,"Patient Name",?44,"SSN",?53,"Lab",?62,"X-Ray",?73,"EKG" + ;W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" + W !," Time",?53,"Time",?62,"Time",?73,"Time",!,?15,"Other Information",?40,"Ward Location",!,?41,"Room-Bed" + W !,SDASH S SDPAGE=SDPAGE+1 + D:SDBC PAINT(SC,SDD) + Q + ; +PAINT(CLINIC,DATE) ; -- paint header barcodes + ; input: CLINIC := clinic ifn + ; DATE := appt date only + ; + W !?10,"Date",?45,"Clinic#",?85,"No",?110,"Yes",! + D BARC(10,$E(DATE,4,7)_$E(DATE,2,3)) + D BARC(45,"%"_CLINIC_"$") + D BARC(85,"N"),BARC(110,"Y") + W !!!!,SDASH + Q + ; +BARC(TAB,X) ; --print barcode + ; input: TAB := tab position + ; X := string to print + ; + W *13,?TAB W @SDBCON,X,@SDBCOFF + Q + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAM10.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAM10.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAM10.m (revision 623) @@ -1,56 +1,54 @@ -SDAM10 ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm ; Compiled March 31, 2008 16:38:47 - ;;5.3;Scheduling;**189,258,403,478,491**;Aug 13, 1993;Build 53 - ; -HDR ; -- list screen header - ; input: SDFN := ifn of pat - ; output: VALMHDR() := hdr array - ; - N VAERR,VA,X - S DFN=SDFN D PID^VADPT - S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")" ;for proper display of patient name for SD*5.3*189 - S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"") - S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15) ;repositioned header to display clinic or patient name properly for SD*5.3*189 - S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient") - S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X)) - Q - ; -PAT ; -- change pat - K TMP ;SD/478 - D FULL^VALM1 S VALMBCK="R" - K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2) - I $D(X),X="" R !!,"Select Patient: ",X:DTIME - D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?" -PAT1 S %=1 I Y>0 W !," ...OK" D YN^DICN I %=0 W " Answer with 'Yes' or 'No'" G PAT1 - I %'=1 S Y=-1 - I Y<0 D G PATQ - .I $G(DFN)>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed." - .I $G(DFN)'>0,SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been selected." - .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect." - .W !!,$G(VALMSG) H 1 - I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P" - S (DFN,SDFN)=+Y K SDCLN,VADM D DEM^VADPT D BLD^SDAM1 ;SD/491 -PATQ Q - ; -INIT ; -- init bld vars - K VALMHDR,SDDA,^TMP("SDAMIDX",$J) - D CLEAN^VALM10 - S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100 - S SDAMDD=$P(^DD(2.98,3,0),U,3) - ; -- format vars |- column -| |- width -| - S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt - S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ; X for date - S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ; N for name - S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ; S for status - S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ; T for time - S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ; C for Consult ;SD/478 - Q - ; -LARGE ; -- too large note - W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because" - W !?11,"too many appointments met date range criteria." D PAUSE^VALM1 - Q - ; -NUL ; -- set nul message - I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1(" No appointments meet criteria.") - Q - ; +SDAM10 ;MJK/ALB - Appt Mgt (Patient cont.); 3/18/05 3:51pm + ;;5.3;Scheduling;**189,258,403,478**;Aug 13, 1993 + ; +HDR ; -- list screen header + ; input: SDFN := ifn of pat + ; output: VALMHDR() := hdr array + ; + N VAERR,VA,X + S DFN=SDFN D PID^VADPT + S VALMHDR(1)=$E($P("Patient: "_$G(^DPT(SDFN,0)),U),1,46)_" ("_VA("BID")_")" ;for proper display of patient name for SD*5.3*189 + S X=$P($$FMT^SDUTL2(SDFN),U,2),X=$S(X["GMT":X,X]"":"MT: "_X,1:"") + S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),47,15) ;repositioned header to display clinic or patient name properly for SD*5.3*189 + S X=$S($D(^DPT(SDFN,.1)):"Ward: "_^(.1),1:"Outpatient") + S VALMHDR(1)=$$SETSTR^VALM1(X,VALMHDR(1),81-$L(X),$L(X)) + Q + ; +PAT ; -- change pat + K TMP ;SD/478 + D FULL^VALM1 S VALMBCK="R" + K X I $D(XQORNOD(0)) S X=$P($P(XQORNOD(0),U,4),"=",2) + I $D(X),X="" R !!,"Select Patient: ",X:DTIME + D RT^SDAMEX S DIC="^DPT(",DIC(0)="EMQ" D ^DIC K DIC G PAT:X["?" +PAT1 S %=1 W !," ...OK" D YN^DICN I %=0 W " Answer with 'Yes' or 'No'" G PAT1 + I %'=1 S Y=-1 + I Y<0 D G PATQ + .I SDAMTYP="P" S VALMSG=$C(7)_"Patient has not been changed." + .I SDAMTYP="C" S VALMSG=$C(7)_"View of clinic remains in affect." + I SDAMTYP'="P" D CHGCAP^VALM("NAME","Clinic") S SDAMTYP="P" + S SDFN=+Y K SDCLN D BLD^SDAM1 +PATQ Q + ; +INIT ; -- init bld vars + K VALMHDR,SDDA,^TMP("SDAMIDX",$J) + D CLEAN^VALM10 + S VALMBG=1,(VALMCNT,SDACNT)=0,BL="",$P(BL," ",30)="",SDMAX=100 + S SDAMDD=$P(^DD(2.98,3,0),U,3) + ; -- format vars |- column -| |- width -| + S X=VALMDDF("APPT#"),AC=$P(X,U,2),AW=$P(X,U,3) ; A for appt + S X=VALMDDF("DATE"),XC=$P(X,U,2),XW=$P(X,U,3) ; X for date + S X=VALMDDF("NAME"),NC=$P(X,U,2),NW=$P(X,U,3) ; N for name + S X=VALMDDF("STAT"),SC=$P(X,U,2),SW=$P(X,U,3) ; S for status + S X=VALMDDF("TIME"),TC=$P(X,U,2),TW=$P(X,U,3) ; T for time + S (CC,CW)="",X=$G(VALMDDF("CONSULT")) I X'="" S CC=$P(X,U,2),CW=$P(X,U,3) ; C for Consult ;SD/478 + Q + ; +LARGE ; -- too large note + W !!?5,*7,"Note: Ending Date was changed to '",$$FDATE^VALM1(SDEND),"' because" + W !?11,"too many appointments met date range criteria." D PAUSE^VALM1 + Q + ; +NUL ; -- set nul message + I '$O(^TMP("SDAM",$J,0)) D SET^SDAM1(" "),SET^SDAM1(" No appointments meet criteria.") + Q + ; Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMODO3.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMODO3.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMODO3.m (revision 623) @@ -1,102 +1,102 @@ -SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98 8:44 PM - ;;5.3;Scheduling;**11,25,46,49,159,529**;Aug 13, 1993;Build 3 - Q -REPORT ; - I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT -START ; - N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK - S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0 - W:$E(IOST,1,2)="C-" @IOF - F S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV="" D Q:SDFIN - . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN S SDVC=SDIV - . S SUB1="" F S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1="" D Q:SDFIN - .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX) - .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV) - .. S SUB2="" F S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2="" D Q:SDFIN - ... S OEN=0 F S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN S SUBCNT=SUBCNT+1,SDCHECK="" D Q:SDFIN - .... S I=0 F S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I S SDFIN='$$PRNT(I) Q:SDFIN - S SUBX=$$SUBCNT(SUB1,SUBX) -EXIT ; - K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX - Q - ; -SUBCNT(SB1,SB1P) ; - I SB1P']""!(SUBCNT'>0) G SUBCNTQ - W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!! - S SUBCNT=0 -SUBCNTQ Q (SB1) - ; -PRNT(I) ; - N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID - S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0)) - S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX S SPRV(XX)="" - S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX="" S SDX(XX)="" - I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ - I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ - I $Y+5>IOSL S Y='$$HDR(SDIV) G:Y PRNTQ -LINE1 ; - S SDSID=$P($G(SDATA),U,2) - W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3) - S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1 - W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds - W ?55,$E($P(SDATA,U,3),1,25) - W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5)) - W ?117,$P(SDATA,U,6) -LINE2 ; - S SCODE=$P(SDATA,U,4) - W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U) - S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") - S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1 - S SDONE=0 - F XX=1:1 D Q:SDONE - . I SDDX1'="" S SDDX1=$O(SDX(SDDX1)) - . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX)) - . I SDPRX']""&(SDDX1']"") S SDONE=1 Q - . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE - . W ! - . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") - . I $D(SDDX1),SORT1'=2 W ?117,SDDX1 - S Y=1 -PRNTQ S:QFLAG Y=0 Q (Y) - ; -HDR(SDIV) ; - N Y - S Y=0 - I SDVC'="",$E(IOST,1,2)="C-" D G:QFLAG HDRQ - . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit" - . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing." - . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q - . W @IOF - S PAGE=PAGE+1 - I $E(IOST,1,2)'="C-",SDVC'="" W @IOF - W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) - W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE - W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") - W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U) - W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE" - W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------" - S Y=1 -HDRQ Q (Y) - ; -NOREP ; - W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) - W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@") - W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") - W !!,"No data found matching sort parameters" - Q - ; -SELPRV(PRV) ; - N Y S Y=1 - I PROVDR=1 G SELPRVQ - I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ - S Y=0 -SELPRVQ Q (Y) - ; -SELDX(DX) ; - N Y S Y=1 - I PDIAG=1 G SELDXQ - S DIC="^ICD9(",DIC(0)="XMS",X=DX_" " ;SD/529 - D ^DIC K DIC I Y<0 S Y=0 G SELDXQ - I $D(PDIAG($P(Y,U))) G SELDXQ - S Y=0 -SELDXQ Q (Y) +SDAMODO3 ;ALB/SCK - PROVIDER DIAGNOSTICS REPORT OUTPUT ; 05 Oct 98 8:44 PM + ;;5.3;Scheduling;**11,25,46,49,159**;Aug 13, 1993 + Q +REPORT ; + I '$D(^TMP("SDRPT",$J)) D NOREP G EXIT +START ; + N SDIV,OEN,SDPRX,SUB1,SUB2,OEN,SDATA,SDX,SPRV,SDCHECK + S (SDIV,SDFIN,SDVC,SUBX,SUB1,SUB2)="",(PAGE,QFLAG,SUBCNT)=0 + W:$E(IOST,1,2)="C-" @IOF + F S SDIV=$O(^TMP("SDRPT",$J,SDIV)) Q:SDIV="" D Q:SDFIN + . I SDIV'=SDVC S SUBX=$$SUBCNT(SUB1,SUBX),SDFIN='$$HDR(SDIV) Q:SDFIN S SDVC=SDIV + . S SUB1="" F S SUB1=$O(^TMP("SDRPT",$J,SDIV,SUB1)) Q:SUB1="" D Q:SDFIN + .. I SUBX'=SUB1 S SUBX=$$SUBCNT(SUB1,SUBX) + .. I SORT1=4!(SORT1=5) I SUBX]"",SUBX'=SUB1 S SDFIN='$$HDR(SDIV) + .. S SUB2="" F S SUB2=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2)) Q:SUB2="" D Q:SDFIN + ... S OEN=0 F S OEN=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN)) Q:'OEN S SUBCNT=SUBCNT+1,SDCHECK="" D Q:SDFIN + .... S I=0 F S I=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I)) Q:'I S SDFIN='$$PRNT(I) Q:SDFIN + S SUBX=$$SUBCNT(SUB1,SUBX) +EXIT ; + K QFLAG,PAGE,SDFIN,SDVC,SDONE,XX,^TMP("SDRPT",$J),SUBCNT,SUBX + Q + ; +SUBCNT(SB1,SB1P) ; + I SB1P']""!(SUBCNT'>0) G SUBCNTQ + W !,SUBCNT," ",$S(SORT2=1!(SORT2=2):"Primary "_$P($T(SORT+SORT2^SDAMODO1),";;",2),1:$P($T(SORT+SORT2^SDAMODO1),";;",2))," entries for ",$S(SORT1=1!(SORT1=3):$P(SB1P,"^"),SORT1=5:$P($G(^DIC(40.7,SB1P,0)),U),1:SB1P),!! + S SUBCNT=0 +SUBCNTQ Q (SB1) + ; +PRNT(I) ; + N Y,SDATA,SPRV,SDX,XX,SCODE,SDDX1,SDPRX,SDSID + S SDATA=(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,0)) + S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"PRV",XX)) Q:'XX S SPRV(XX)="" + S XX="" F S XX=$O(^TMP("SDRPT",$J,SDIV,SUB1,SUB2,OEN,I,"DX",XX)) Q:XX="" S SDX(XX)="" + I SORT1=1,'$$SELPRV(SUB1) S Y=1 G PRNTQ + I SORT1=2,'$$SELDX(SUB1) S Y=1 G PRNTQ + I $Y+5>IOSL S Y='$$HDR(SDIV) G:Y PRNTQ +LINE1 ; + S SDSID=$P($G(SDATA),U,2) + W !,$P(^DPT($P($G(SDATA),U),0),U)_" "_$P(SDSID,"-",3) + S:SDCHECK="" SDCHECK=SDSID I SDSID'=SDCHECK S SUBCNT=SUBCNT+1 + W ?32,$P($$FMTE^XLFDT(OEN,1),":",1,2) ; modified to drop seconds + W ?55,$E($P(SDATA,U,3),1,25) + W ?90,$S(+$P(SDATA,U,5)>0:$P(^VA(200,+$P(SDATA,U,5),0),U),1:$P(SDATA,U,5)) + W ?117,$P(SDATA,U,6) +LINE2 ; + S SCODE=$P(SDATA,U,4) + W !?56,$P($G(^DIC(40.7,+SCODE,0)),U,2),"/",$P($G(^DIC(40.7,+SCODE,0)),U) + S SDPRX="",SDPRX=$O(SPRV(SDPRX)) I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") + S SDDX1="",SDDX1=$O(SDX(SDDX1)) I $D(SDDX1),SORT1'=2 W ?117,SDDX1 + S SDONE=0 + F XX=1:1 D Q:SDONE + . I SDDX1'="" S SDDX1=$O(SDX(SDDX1)) + . I SDPRX'="" S SDPRX=$O(SPRV(SDPRX)) + . I SDPRX']""&(SDDX1']"") S SDONE=1 Q + . I $Y+5>IOSL S SDONE='$$HDR(SDIV) Q:SDONE + . W ! + . I $D(SDPRX),SORT1'=1 W ?90,$S(+SDPRX>0:$P(^VA(200,SDPRX,0),U),1:"") + . I $D(SDDX1),SORT1'=2 W ?117,SDDX1 + S Y=1 +PRNTQ S:QFLAG Y=0 Q (Y) + ; +HDR(SDIV) ; + N Y + S Y=0 + I SDVC'="",$E(IOST,1,2)="C-" D G:QFLAG HDRQ + . K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or '^' to exit" + . S DIR("?",1)="Pressing any key other than the '^' key will scroll to the next screen",DIR("?")="The '^' key will exit the listing." + . D ^DIR K DIR I $D(DTOUT)!($D(DUOUT)) S QFLAG=1 Q + . W @IOF + S PAGE=PAGE+1 + I $E(IOST,1,2)'="C-",SDVC'="" W @IOF + W !!,"Provider/Diagnosis Encounter Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) + W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@"),?(IOM-10),"Page: ",PAGE + W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") + W !,"Division: ",$P($G(^DG(40.8,SDIV,0)),U) + W !!,"PATIENT",?32,"ENCOUNTER DATE",?55,"CLINIC/PRIMARY STOP CODE",?90,"PROVIDER",?117,"DX CODE" + W !,"-------------------",?32,"------------------",?55,"------------------------",?90,"--------------",?117,"-------" + S Y=1 +HDRQ Q (Y) + ; +NOREP ; + W !!,"Provider/Diagnosis Report sorted by ",$P($T(SORT+SORT1^SDAMODO1),";;",2)," and ",$P($T(SORT+SORT2^SDAMODO1),";;",2) + W ?(IOM-40),"Report Date: ",$P($$NOW^VALM1,"@") + W !,"Inclusion Dates: ",$P($$FMTE^XLFDT(SDBEG,1),"@")," to ",$P($$FMTE^XLFDT(SDEND,1),"@") + W !!,"No data found matching sort parameters" + Q + ; +SELPRV(PRV) ; + N Y S Y=1 + I PROVDR=1 G SELPRVQ + I $D(PROVDR($P(PRV,"^",2))) G SELPRVQ + S Y=0 +SELPRVQ Q (Y) + ; +SELDX(DX) ; + N Y S Y=1 + I PDIAG=1 G SELDXQ + S DIC="^ICD9(",DIC(0)="MZ",X=DX + D ^DIC K DIC I Y<0 S Y=0 G SELDXQ + I $D(PDIAG($P(Y,U))) G SELDXQ + S Y=0 +SELDXQ Q (Y) Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMVSC.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMVSC.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDAMVSC.m (revision 623) @@ -1,64 +1,54 @@ -SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96 1:39 PM ] ; Compiled August 20, 2007 14:28:26 - ;;5.3;Scheduling;**394,417,491**;Aug 13, 1993;Build 53 - ; - ; - ;*************************************************************************************************************************** - ; - ; ***** NOTE ***** - ; - ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301) - ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance. - ; - ;DBIA #4433 SUBSCRIPTION - ; - ; - ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE) - ; - ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1] - ; ^DPT(IEN,"S",DATE,0) ^ (#9.5) APPOINTMENT TYPE [16P:409.1] - ; ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT. - ; - ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS. - ; - ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to - ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE - ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE - ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR. - ; - ; - ;**************************************************************************************************************************** - Q -EN ;Entry Point - Q:'$G(SDOE) - N SDN,SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF - S SDOED=$G(^SCE(SDOE,0)) Q:SDOED="" - S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U) - ;GET APPOINTMENT FROM EVENT OUTPUT ARRAY - I $G(^TMP("SDAMEVT",$J,"AFTER","DPT")) S SDAPDPT=$P($G(^TMP("SDAMEVT",$J,"AFTER","DPT")),"^",16) - E S SDAPDPT=$P(SDOED,"^",10) ;APP TYPE - S SDVSCL=$P(SDOED,U,4) - S SDVSTD=$P(SDOED,U,5) - Q:'SDVSTD ; ticket #194210 ; do not proceed if no pointer to a visit - Q:'$D(^AUPNVSIT(SDVSTD,800)) - S SDSCV=+$$GET1^DIQ(9000010,SDVSTD_",",80001,"I") ;SC flag in Visit file - S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") ;default appt type - ;find if credit stop secondary visit exists. - N SDVSTDS,SDOE1 S SDOE1="" S SDVSTDS=$O(^AUPNVSIT("AD",SDVSTD,"")) - I SDVSTDS>0 S SDOE1=$O(^SCE("AVSIT",SDVSTDS,"")) - I SDSCV I SDAPDPT'=11 S SDAPDPT=11 D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE) - I 'SDSCV I SDAPDPT=11 D D APPT F SDE=SDOE,SDOE1 I SDE>0 D SCE(SDE) - . I SDAPDF'="" S SDAPDPT=SDAPDF ; set to default if exists for this clinic - . E S SDAPDPT=9 ; set to regular - Q -SCE(SDE) ;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER - S SDIENS=SDE_"," K ^TMP("SDAMSCE",$J) - D FDA^DILF(409.68,SDIENS,.1,,SDAPDPT,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") - I $D(^TMP("SDAMSCE",$J,"DIERR")) D Q - .W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q - D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") - Q -APPT ;quit if clinic in event doesn't match clinic in ^DPT - ;set up app type in DPT - I +$G(^TMP("SDAMEVT",$J,"AFTER","DPT"))'=+$G(^DPT(SDDFN,"S",SDAPDT,0)) Q - I $D(^DPT(SDDFN,"S",SDAPDT,0)) S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPDPT -END Q +SDAMVSC ;;OIFO-BAY PINES/TEH - Appt Event Driver Utilities-Validate SC Appt type ; 12/1/91 [ 09/19/96 1:39 PM ] + ;;5.3;Scheduling;**394,417**;Aug 13, 1993 + ; + ;*************************************************************************************************************************** + ; + ; ***** NOTE ***** + ; + ;This software was created to be used with the SCHEDULING V5.3 appointment management package. The SRA API (SDAMA301) + ;was employed to retrieve data from the PATIENT APPOINTMENT file (2.98) due inpart to VA Fileman non-compliance. + ; + ;DBIA #4433 SUBSCRIPTION + ; + ;Entry Point EN. This routine requires the OUTPATIENT ENOUNTER IEN (variable SDOE) + ; + ;GLOBALS: ^SCE(IEN,0) (#.1) APPOINTMENT TYPE [10P:409.1] + ; ^DPT(IEN,"S",DATE,0) ^ (#9.5) APPOINTMENT TYPE [16P:409.1] + ; ^SD(409.41,0)=OUTPATIENT CLASSIFCATION TYPE "Was treatment for SC Condition? " QUESTION FOR CHECKOUT. + ; + ;PROTOCOLS: This routine is called from the SDAM APPOINTMENT EVENTS. + ; + ;This validates that both the OUTPATIENT ENCOUNTER and the PATIENT SCHEDULING NODES for APPOINTMENT TYPE are (pointer to + ;409.1 APPOINTMENT TYPE) are set to the "SERVICE CONNECTED" appointment type when the response to the CLASSIFICATION TYPE + ;"Was treatment for SC Condition?" question is answered "YES". If the question is answered "NO" and the APPOINTMENT TYPE + ;is SERVICE CONNECTED, then the APPOINTMENT TYPE is reverted to REGULAR. + ; + ; + ;**************************************************************************************************************************** + Q +EN ;Entry Point + G END:'$D(SDOE),END:'$G(SDOE),END:SDOE="" + N SDVSCL,SDVSTD,SDAPDF,SDDPTYP,SDOED,SDVSTD,SDVDPTD,SDVSCD,SDSCV,SDAPPTY,SDAPDT,SDDFN,SDVSTD,SDIENS,SDARRAY,SDAPDF + S SDOED=$G(^SCE(SDOE,0)) G END:SDOED="" + S SDDFN=$P(SDOED,U,2),SDAPDT=$P(SDOED,U) I '$D(^DPT(SDDFN,"S",SDAPDT,0)) Q + ;GET APPOINTMENT FROM 2.98 + N SDAMIENS S SDAMIENS=SDAPDT_","_SDDFN_"," + S SDAPDPT=$$GET1^DIQ(2.98,SDAMIENS,9.5,"I") + S SDVSCL=$P(SDOED,U,4) + S SDVSTD=$P(SDOED,U,5),SDSCV=$$GET1^DIQ(9000010,SDVSTD_",",80001,"I") + S SDAPDF=$$GET1^DIQ(44,SDVSCL_",",2507,"I") + S SDAPPTY=$S(SDSCV=1:11,$D(SDAPDPT):SDAPDPT,SDAPDT'="":SDAPDF,1:9) D + .;Set FDA for SCE(ien,0) OUTPATIENT ENCOUNTER + .S SDIENS=SDOE_"," K ^TMP("SDAMSCE",$J) + .D FDA^DILF(409.68,SDIENS,.1,,SDAPPTY,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") + .I $D(^TMP("SDAMSCE",$J,"DIERR")) D + ..W !,"Processing Error ",^TMP("SDAMSCE",$J,"DIERR",1) Q + .D FILE^DIE(,"^TMP(""SDAMSCE"",$J)","^TMP(""SDAMSCE"",$J)") + .;Set FDA for ^DPT(ien,"S") PATIENT APPOINTMENT. + .K ^TMP($J,"SDAMA301") + .N SDAMVSCX S SDARRAY(1)=SDAPDT_";"_SDAPDT,SDARRAY(4)=SDDFN,SDARRAY("FLDS")=10,SDAMVSCX=$$SDAPI^SDAMA301(.SDARRAY) + .I 'SDAMVSCX D Q + ..W !,"Processing Error " + .S SDDPTYP=+$P($G(^TMP($J,"SDAMA301",SDDFN,SDVSCL,SDAPDT)),U,10) I SDDPTYP'=SDAPPTY D + ..S $P(^DPT(SDDFN,"S",SDAPDT,0),U,16)=SDAPPTY +END Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDC.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDC.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDC.m (revision 623) @@ -1,69 +1,67 @@ -SDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm - ;;5.3;Scheduling;**15,32,79,132,167,478,487,523**;Aug 13, 1993;Build 6 - N SDATA,SDCNHDL ; for evt dvr -SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL - S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0 - S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL") - S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=% - K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"") - I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC1 - I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N - I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) -N I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC1 ; KILLs node if not holiday - I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W - W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",! - K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q - I ^SC(SC,"ST",SD,1)["X" G ^SDC2 -W S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W - I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL - Q:%<1 -WP S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP - Q:(%-1) -F R !,"STARTING TIME: ",X:DTIME Q:U[X D TC^SDC2 G F:Y<0 S FR=Y,ST=% -T R !,"ENDING TIME: ",X:DTIME Q:U[X D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T - I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F -ROPT R !,"Reason for cancellation: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT - N CANREM S CANREM=I - Q:I["^" I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP - S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1) -SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO - S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0) - S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y="" - F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X160!($L(CANREM)<3) W !,*7,"Reason must be between 3 to 160 characters long",! G ALL - D S S ^(1)=" "_$E(SD,6,7)_" **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) -C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'0 D - .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1) - .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL) - .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C" - .S:$D(^DPT(DFN,"S",FR,0)) NODE=^(0) ;added SD/523 - .Q:$P(NODE,U,1)'=SC ;added SD/523 - .S ^DPT("ASDCN",SC,FR,DFN)="" - .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478 - .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE - G C - ; -B S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC - Q -MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N" - S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN) - S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL - S DH=SDH K SDH D CK1,EVT - K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q -CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q - Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q - Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1 - Q:SDX K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q - ; -EVT ; -- separate tag if need to NEW vars - ; -- cancel event - N FR,I,SDTIME,DH,SC - D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL - Q +SDC ;MAN/GRR,ALB/LDB - CANCEL A CLINIC'S AVAILABILITY ; 3/2/05 2:11pm + ;;5.3;Scheduling;**15,32,79,132,167,478,487**;Aug 13, 1993 + N SDATA,SDCNHDL ; for evt dvr +SDC1 K SDLT,SDCP S NOAP="" D LO^DGUTL + S DIC=44,DIC(0)="MEQA",DIC("S")="I $P(^(0),""^"",3)=""C"",'$G(^(""OOS""))",DIC("A")="Select CLINIC NAME: " D ^DIC K DIC("S"),DIC("A") G:'$D(^SC(+Y,"SL")) END^SDC0 + S SC=+Y,SL=^("SL"),%DT="AEXF",%DT("A")="CANCEL '"_$P(Y,U,2)_"' FOR WHAT DATE: " D ^%DT K %DT G:Y<0 END^SDC0 ;NAKED REFERNCE - ^SC(IFN,"SL") + S (SD,CDATE)=Y,%=$P(SL,U,6),SI=$S(%="":4,%<3:4,%:%,1:4),%=$P(SL,U,3),STARTDAY=$S($L(%):%,1:8) D NOW^%DTC S SDTIME=% + K SDRE,SDIN,SDRE1 I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D:Y DTS^SDUTL S SDRE1=$S(SDRE:" to "_Y,1:"") + I $S('$D(SDIN):0,SDIN'>0!(SDIN>SD):0,SDRE'>SD&(SDRE):0,1:1) W !,*7,"Clinic is inactive ",$S('SDRE:"as of ",1:"from ") S Y=SDIN D DTS^SDUTL W Y,SDRE1 G SDC1 + I '$D(^SC(SC,"ST",SD,1)) S DH="" D B S ^SC(SC,"ST",SD,1)=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(SD,6,7)_$J("",SI+SI-6)_DH,^(0)=SD G N + I ^(1)["CANCELLED" W !,"APPOINTMENTS HAVE ALREADY BEEN CANCELLED",!,*7 S ANS="N",SDTIME="*",SDV1=$S($P(^SC(SC,0),"^",15):$P(^(0),"^",15),1:+$O(^DG(40.8,0))) K SDX G ASKL^SDC0 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) +N I '$F(^SC(SC,"ST",SD,1),"[") K:^(1)?2U.E ^SC(SC,"ST",SD) W !,*7,"CLINIC DOES NOT MEET ON THAT DAY" G SDC1 ; KILLs node if not holiday + I $O(^SC(SC,"S",SD))\1-SD W *7,!?5,"NO APPOINTMENTS SCHEDULED" S NOAP=1 G W + W !,"FIRST, I'LL LIST THE EXISTING APPOINTMENTS",! + K DUOUT,DTOUT D ^SDC1 I $D(DUOUT)!$D(DTOUT) D END^SDC0 Q + I ^SC(SC,"ST",SD,1)["X" G ^SDC2 +W S DH=0,%="" W !,"WANT TO CANCEL THE WHOLE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G W + I %=1 G WP:$$COED^SDC4(SC,SD,SD+.2359,1),ALL + Q:%<1 +WP S %="" W !,"WANT TO CANCEL PART OF THE DAY" D YN^DICN I '% W !,"REPLY YES (Y) OR NO (N)" G WP + Q:(%-1) +F R !,"STARTING TIME: ",X:DTIME Q:U[X D TC^SDC2 G F:Y<0 S FR=Y,ST=% +T R !,"ENDING TIME: ",X:DTIME Q:U[X D TC^SDC2 G T:Y<0 S SDHTO=X,TO=Y I TO'>FR W !,"Ending time must be greater than starting time",*7 G T + I $$COED^SDC4(SC,FR,TO,1) K FR,SDHTO,TO,ST W ! G F +ROPT R !,"Reason for cancellation: ",I:DTIME I I?1"?".E W !,"YOU MAY ENTER A MESSAGE CONCERNING THE CANCELLATION HERE" G ROPT + N CANREM S CANREM=I + Q:I["^" I '$D(^SC(SC,"SDCAN",0)) S ^SC(SC,"SDCAN",0)="^44.05D^"_FR_"^1" G SKIP + S A=^SC(SC,"SDCAN",0),SDCNT=$P(A,"^",4),^SC(SC,"SDCAN",0)=$P(A,"^",1,2)_"^"_FR_"^"_(SDCNT+1) +SKIP S ^SC(SC,"SDCAN",FR,0)=FR_"^"_SDHTO + S NOAP=$S($O(^SC(SC,"S",(FR-.0001)))'>0:1,$O(^SC(SC,"S",(FR-.0001)))>TO:1,1:0) I 'NOAP S NOAP=$S($O(^SC(SC,"S",+$O(^SC(SC,"S",(FR-.0001))),0))="MES":1,1:0) + S ^SC(SC,"S",FR,0)=FR,^("MES")="CANCELLED UNTIL "_X_$S(I?.P:"",1:" ("_I_")") D S S I=^(1),I=I_$J("",%-$L(I)),Y="" + F X=0:2:% S DH=$E(I,X+SI+SI),P=$S(X160!($L(CANREM)<3) W !,*7,"Reason must be between 3 to 160 characters long",! G ALL + D S S ^(1)=" "_$E(SD,6,7)_" **CANCELLED**",FR=SD,TO=SD+.9 ;NAKED REFERENCE - ^SC(IFN,"ST",Date,1) +C S FR=$O(^SC(SC,"S",FR)) I FR<1!(FR'0 D + .S DFN=+^SC(SC,"S",FR,1,I,0),SDCNHDL=$$HANDLE^SDAMEVT(1) + .D BEFORE^SDAMEVT(.SDATA,DFN,FR,SC,I,SDCNHDL) + .S $P(^SC(SC,"S",FR,1,I,0),"^",9)="C" + .S ^DPT("ASDCN",SC,FR,DFN)="" + .S SDSC=SC,SDTTM=FR,SDPL=I,TDH=DH,TMPD=CANREM D CANCEL^SDCNSLT S DH=TDH ;SD/478 + .I $D(^DPT(DFN,"S",FR,0)),$P(^(0),"^",2)'["C" S $P(^(0),"^",2)="C",$P(^(0),"^",12)=DUZ,$P(^(0),"^",14)=SDTIME,DH=DH+1,TDH=DH,DIE="^DPT(DFN,"_"""S"""_",",DR="17///^S X=CANREM",DA=FR D ^DIE S DH=TDH D MORE + G C + ; +B S X=SD D DOW^SDM0 S DOW=Y,SS=+$O(^SC(SC,"T"_Y,X)) I $D(^(SS,1)),^(1)]"" S DH=^(1),DO=X+1,DA(1)=SC + Q +MORE I $D(^SC("ARAD",SC,FR,DFN)) S ^(DFN)="N" + S SDIV=$S($P(^SC(SC,0),"^",15)]"":$P(^(0),"^",15),1:" 1"),SDV1=$S(SDIV:SDIV,1:+$O(^DG(40.8,0))) I $D(^DPT("ASDPSD","C",SDIV,SC,FR,DFN)) K ^(DFN) + S SDH=DH,SDTTM=FR,SDSC=SC,SDPL=I,SDRT="D" D RT^SDUTL + S DH=SDH K SDH D CK1,EVT + K SD1,SDIV,SDPL,SDRT,SDSC,SDTTM,SDX Q +CK1 S SDX=0 F SD1=FR\1:0 S SD1=$O(^DPT(DFN,"S",SD1)) Q:'SD1!((SD1\1)'=(FR\1)) I $P(^(SD1,0),"^",2)'["C",$P(^(0),"^",2)'["N" S SDX=1 Q + Q:SDX F SD1=2,4 I $D(^SC("AAS",SD1,FR\1,DFN)) S SDX=1 Q + Q:SDX IF $D(^SCE(+$$EXAE^SDOE(DFN,FR\1,FR\1),0)) S SDX=1 + Q:SDX K ^DPT("ASDPSD","B",SDIV,FR\1,DFN) Q + ; +EVT ; -- separate tag if need to NEW vars + ; -- cancel event + N FR,I,SDTIME,DH,SC + D CANCEL^SDAMEVT(.SDATA,DFN,SDTTM,SDSC,SDPL,0,SDCNHDL) K SDATA,SDCNHDL + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAS.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAS.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAS.m (revision 623) @@ -1,53 +1,53 @@ -SDCLAS ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92 11:42 - ;;5.3;Scheduling;**63,243,517,523**;Aug 13, 1993;Build 6 - ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS - S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0 - S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL - S SDIFN="",SDI=0,DIC="^SC(",DIC(0)="EFMQ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),U,15)=DIV:1,1:0)" D SELECT^SDCLAS0 K DIC Q:X["^" - S Y=DT D DTS^SDUTL S SDTS=Y -OPT2 W !!,"Select 'As of' Date: ",SDTS," // " R X:DTIME Q:X["^" I X']"" S SDTS=DT G OVR - S %DT(0)=-DT,%DT="EPX" D ^%DT K %DT - I Y'>0 W !,*7,"A date must be entered here to get a 'snapshot' of the clinic's enrollment as of",!," this date. Date can not be in future." G OPT2 - S SDTS=+Y -OVR I SDSRT="C",SDSAV']"",SDIFN'="ALL",$S('$D(^SC(SDIFN,"I")):0,+^("I")=0:0,+^("I")>SDTS:0,+$P(^("I"),"^",2)'>SDTS&(+$P(^("I"),"^",2)'=0):0,1:1) W !,"Clinic ",$S(SDTS=DT:"is",1:"was")," inactive" W:SDTS
0 D PT - D:'SDFAST AEB^SDCLAS0 G ^SDCLAS1 -ALL S ONE=0 I SDSAV']"" S SDIFN=0 F S SDIFN=$O(^SC(SDIFN)) Q:'SDIFN I $P(^(SDIFN,0),"^",3)="C" D APPT - I SDSAV]"" D APART S SDIFN=0 F S SDIFN=$O(SDZ(SDIFN)) Q:'SDIFN I $D(^SC(SDIFN,0)),$P(^(0),"^",3)="C" D APPT - G ^SDCLAS1 -APPT D CHECK I 'POP K ^UTILITY($J,"PAT",SDIFN) D INIT F SDAPPT=SDTS:0 S SDAPPT=$O(^SC(SDIFN,"S",SDAPPT)) D:SDAPPT>0 PT I SDAPPT'>0 D:'SDFAST AEB^SDCLAS0 Q - Q -PT S SD=0 F S SD=$O(^SC(SDIFN,"S",SDAPPT,1,SD)) Q:'SD Q:'$D(^(SD,0)) S DFN=+^(0) D PT1 - Q -PT1 I '$D(^UTILITY($J,"PAT",SDIFN,DFN)),$D(^DPT(DFN,0)),$D(^("S",SDAPPT,0)),$P(^(0),"^",2)=""!($P(^(0),"^",2)="I"),$S('$D(^DPT(DFN,.35)):1,'^(.35):1,1:0) D S,EXT^SDCLAS0 - Q -S S Y(0)=^DPT(DFN,0),SDACT=1,SDENR=0 D SET1 - S I=0 F S I=$O(^DPT(DFN,"DE","B",SDIFN,I)) Q:'I I $D(^DPT(DFN,"DE",I,0)) D EDENR Q:SDENR - S ^UTILITY($J,"PAT",SDIFN,DFN)="" S:'$D(Y(1))!('SDENR) Y(1)="" I '$D(^UTILITY($J,"PAT"," ",DFN)) D MT S ^UTILITY($J,"PAT"," ",DFN)=$P(Y(0),"^",9)_"^"_SDELIG_"^"_SDZIP_"^"_$P(Y(0),"^",3)_U_SDMT - Q -EDENR K Y(1) S I1=0 F S I1=$O(^DPT(DFN,"DE",I,1,I1)) Q:'I1 S X=$P(^(I1,0),"^"),X(1)=$P(^(0),"^",3) Q:X>SDTS S:'X(1)!(X(1)>SDTS) Y(1)=^(0),SDENR=1 Q:SDENR - Q -SET1 S SDELIG=$S($D(^DPT(DFN,.36)):$P(^(.36),"^",1),1:""),SDELIG=$S($D(^DIC(8,+SDELIG,0)):SDELIG,1:""),SDELIG(1)=$S(SDELIG]"":$P(^(0),"^",5),1:""),SDZIP=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",6),1:"") - Q -MT ; - S SDMT="*" Q:SDELIG(1)']"" I SDELIG(1)="N" S SDMT="N" Q - S SDMT=$$LST^DGMTU(DFN) I SDMT']"" S SDMT=$S(SDELIG'=6:"A",1:"X") Q - S:$P(SDMT,U,2)>SDTS SDMT=$$LST^DGMTU(DFN,SDTS) - I $P(SDMT,U,4)="P" S SDMT=$$PA^DGMTUTL($P(SDMT,U)),SDMT=$S('$D(SDMT):"U",SDMT="MT":"C",SDMT="GMT":"G",1:"U") - E S SDMT=$P(SDMT,U,4) - I SDMT="" S SDMT="X" - I SDMT="P" S SDMT="C" - I SDMT="R" S SDMT="U" - I SDMT="N" S SDMT="A" - D DOM^SDOPC4(DFN,SDTS_.9,.SDMT) I SDMT="X0" S SDMT="X" - K SDMT1 Q -CHECK S POP=0 I SDSRT="S",SDSTOP'="ALL",$P(^SC(SDIFN,0),"^",7)'=SDSTOP S POP=1 Q - I $S(DIV="":1,$P(^SC(SDIFN,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SDIFN,"I")):1,+^("I")=0:1,+^("I")>DT:1,+$P(^("I"),"^",2)'>DT&(+$P(^("I"),"^",2)'=0):1,1:0) Q - S POP=1 Q -APART S SDZ="" F I=1:1 Q:$P(SDSAV,",",I)']"" S SDZ=$P(SDSAV,",",I) D:SDZ["--" SPLIT^SDCLAS0 I SDZ'["--" S:'$D(SDZ(+SDZ)) SDZ(+SDZ)="" - Q -INIT F I1="SDENR","SDACT" S I2="^UTILITY("_$J_","""_I1_""","_SDIFN_")",@I2=0 - Q +SDCLAS ;ALB/TMP,MRY - Clinic Assignment List Extract ;12/23/92 11:42 + ;;5.3;Scheduling;**63,243,517**;Aug 13, 1993;Build 4 + ;SD/517 CORRECTED ALL $NEXT FUNCTIONAL COMMANDS + S DIV="" D DIV^SDUTL I $T D CALST^SDDIV Q:Y<0 + S:'$D(DTIME) DTIME=300 I '$D(DT) D DT^SDUTL + S SDIFN="",SDI=0,DIC="^SC(",DIC(0)="EFMQ",DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$S(DIV="""":1,$P(^(0),U,15)=DIV:1,1:0)" D SELECT^SDCLAS0 K DIC Q:X["^" + S Y=DT D DTS^SDUTL S SDTS=Y +OPT2 W !!,"Select 'As of' Date: ",SDTS," // " R X:DTIME Q:X["^" I X']"" S SDTS=DT G OVR + S %DT(0)=-DT,%DT="EPX" D ^%DT K %DT + I Y'>0 W !,*7,"A date must be entered here to get a 'snapshot' of the clinic's enrollment as of",!," this date. Date can not be in future." G OPT2 + S SDTS=+Y +OVR I SDSRT="C",SDSAV']"",SDIFN'="ALL",$S('$D(^SC(SDIFN,"I")):0,+^("I")=0:0,+^("I")>SDTS:0,+$P(^("I"),"^",2)'>SDTS&(+$P(^("I"),"^",2)'=0):0,1:1) W !,"Clinic ",$S(SDTS=DT:"is",1:"was")," inactive" W:SDTS
SDTS S:'X(1)!(X(1)>SDTS) Y(1)=^(0),SDENR=1 Q:SDENR + Q +SET1 S SDELIG=$S($D(^DPT(DFN,.36)):$P(^(.36),"^",1),1:""),SDELIG=$S($D(^DIC(8,+SDELIG,0)):SDELIG,1:""),SDELIG(1)=$S(SDELIG]"":$P(^(0),"^",5),1:""),SDZIP=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",6),1:"") + Q +MT ; + S SDMT="*" Q:SDELIG(1)']"" I SDELIG(1)="N" S SDMT="N" Q + S SDMT=$$LST^DGMTU(DFN) I SDMT']"" S SDMT=$S(SDELIG'=6:"A",1:"X") Q + S:$P(SDMT,U,2)>SDTS SDMT=$$LST^DGMTU(DFN,SDTS) + I $P(SDMT,U,4)="P" S SDMT=$$PA^DGMTUTL($P(SDMT,U)),SDMT=$S('$D(SDMT):"U",SDMT="MT":"C",SDMT="GMT":"G",1:"U") + E S SDMT=$P(SDMT,U,4) + I SDMT="" S SDMT="X" + I SDMT="P" S SDMT="C" + I SDMT="R" S SDMT="U" + I SDMT="N" S SDMT="A" + D DOM^SDOPC4(DFN,SDTS_.9,.SDMT) I SDMT="X0" S SDMT="X" + K SDMT1 Q +CHECK S POP=0 I SDSRT="S",SDSTOP'="ALL",$P(^SC(SDIFN,0),"^",7)'=SDSTOP S POP=1 Q + I $S(DIV="":1,$P(^SC(SDIFN,0),"^",15)=DIV:1,1:0),$S('$D(^SC(SDIFN,"I")):1,+^("I")=0:1,+^("I")>DT:1,+$P(^("I"),"^",2)'>DT&(+$P(^("I"),"^",2)'=0):1,1:0) Q + S POP=1 Q +APART S SDZ="" F I=1:1 Q:$P(SDSAV,",",I)']"" S SDZ=$P(SDSAV,",",I) D:SDZ["--" SPLIT^SDCLAS0 I SDZ'["--" S:'$D(SDZ(+SDZ)) SDZ(+SDZ)="" + Q +INIT F I1="SDENR","SDACT" S I2="^UTILITY("_$J_","""_I1_""","_SDIFN_")",@I2=0 + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAV0.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAV0.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCLAV0.m (revision 623) @@ -1,48 +1,46 @@ -SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM - ;;5.3;Scheduling;**184,439,490,517,529**;Aug 13, 1993;Build 3 - ;SD/517 CHANGED FOR LOOPS - I 'VAUTC S SDC=0 F S SDC=$O(VAUTC(SDC)) Q:'SDC S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 - I VAUTC S SDC=0 F S SDC=$O(^SC(SDC)) Q:'SDC I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 - I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1 - ;following line commented off per SD*529 - ;S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q - D END^SDCLAV Q -S1 S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^") - S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC - Q -NM ;called by SDCLAV1 - SD/517 CHANGED FOR LOOP - S SDAP1=0 F S SDAP1=$O(^SC(SDC,"S",SDAP,1,SDAP1)) Q:'SDAP1 D NM1 - K M1,SDN1,SDN2,SDN3,SDC3,SDAP1 ; SD*5.3*439 added Kill of local vars - Q -NM1 I '$D(^SC(SDC,"S",SDAP,1,SDAP1,0)) N POP S POP=0 D CHECK,KILL Q ;added SD/517 - S SDN1=+^SC(SDC,"S",SDAP,1,SDAP1,0),M1=$P(^(0),"^",2),SDC3=$P(^(0),"^",9),SDN2=$P(^DPT(+SDN1,0),"^"),SDN3=$P(^(0),"^",9),SDN3=$S(SDN3="":"UNKNOWN",1:SDN3) I $D(SDCI) D NM2 Q - ; SD*5.3*439 added quit if clinic in "S" node not = to selected clinic - I '$D(SDCI),$D(^DPT(SDN1,"S",SDAP,0)),$P(^(0),"^",2)'["C",$P(^(0),"^",2)'="N",$P(^(0),"^",2)'="NA" Q:$P(^(0),U,1)'=SDC D NM2 Q - Q - ;SD*5.3*490 do not display appts prior to clinic start date -NM2 Q:$P(SDAP,".",1)<$O(^SC(SDC,"T",0)) ;SD*5.3*490 - S:$D(^DPT(SDN1,"S",SDAP,0)) ^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3)=M1_$S(($P(^DPT(SDN1,"S",SDAP,0),"^",2)["C"):"^*",SDC3="C":"^*",($P(^(0),"^",2)="N"):"^**",($P(^(0),"^",2)="NA"):"^**",1:"") - S:$D(^DPT(SDN1,"S",SDAP,0)) $P(^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3),"^",3)=$S($P(^DPT(SDN1,"S",SDAP,0),"^",7)=4:"***",1:"") - Q - ; -CHECK ;Added SD/517 - N SDIEN,NODE,NODE0,HDFN,HDNAM,HDSN,POP - S SDIEN=0,NODE="",HDAP1=SDAP1 - F S SDIEN=$O(^SCE("B",SDAP,SDIEN)) Q:'SDIEN D - .S NODE=^SCE(SDIEN,0) - .Q:$P(NODE,U,4)'=SDC - .S HDFN=$P(NODE,U,2),HDNAM=$P(^DPT(HDFN,0),U),HDSN=$P(^(0),U,9) - .Q:$D(^UTILITY($J,"SDNMS",D,SDV,SDAP,HDNAM,HDSN)) - .S POP=0 D CHECK1 Q:POP - .S SDN1=$P(NODE,U,2),SDN2=$P(^DPT(SDN1,0),U),SDN3=$P(^DPT(SDN1,0),U,9),M1="",SDC3="" - .D NM2 - Q - ; -CHECK1 ;Added SD/517 - S HDAP1=$O(^SC(SDC,"S",SDAP,1,HDAP1)) Q:'HDAP1 - Q:'$D(^SC(SDC,"S",SDAP,1,HDAP1,0)) S NODE0=^(0) - I $P(NODE0,U,1)=HDFN S POP=1 Q - Q - ; -KILL K SDIEN,NODE,NODE0,POP,HDFN,HDNAM,HDSN,HDAP1 ;added SD/517 - Q +SDCLAV0 ;ALB/LDB - OUTPUT PATTERNS (cont.) ; 05 Mar 99 11:31 AM + ;;5.3;Scheduling;**184,439,490,517**;Aug 13, 1993;Build 4 + ;SD/517 CHANGED FOR LOOPS + I 'VAUTC S SDC=0 F S SDC=$O(VAUTC(SDC)) Q:'SDC S SDV=VAUTC(SDC) D:VAUTD!($D(VAUTD(+$P(^SC(SDC,0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 + I VAUTC S SDC=0 F S SDC=$O(^SC(SDC)) Q:'SDC I $P(^(SDC,0),"^",3)="C" D:VAUTD!($D(VAUTD(+$P(^(0),"^",15))))!('$P(^(0),"^",15)&$D(VAUTD($P(^DG(43,1,"GL"),"^",3)))) S1 + I $D(^UTILITY($J,"SDNMS")) D S2^SDCLAV1 + S DGTCH="CLINIC AVAILABILITY REPORT^CLINIC^PAGE#" D:$E(IOST,1,2)="P-" TP^DGUTL K SDBD,SDCI,SDED D END^SDCLAV Q +S1 S SD=^SC(SDC,0),D=$S($P(SD,"^",15):$P(SD,"^",15),1:$P(^DG(43,1,"GL"),"^",3)),SD5=0,SDNM=$P(SD,"^") + S $P(^UTILITY($J,"SDNMS",D,SDNM),"^",3)=SDC + Q +NM ;called by SDCLAV1 - SD/517 CHANGED FOR LOOP + S SDAP1=0 F S SDAP1=$O(^SC(SDC,"S",SDAP,1,SDAP1)) Q:'SDAP1 D NM1 + K M1,SDN1,SDN2,SDN3,SDC3,SDAP1 ; SD*5.3*439 added Kill of local vars + Q +NM1 I '$D(^SC(SDC,"S",SDAP,1,SDAP1,0)) N POP S POP=0 D CHECK,KILL Q ;added SD/517 + S SDN1=+^SC(SDC,"S",SDAP,1,SDAP1,0),M1=$P(^(0),"^",2),SDC3=$P(^(0),"^",9),SDN2=$P(^DPT(+SDN1,0),"^"),SDN3=$P(^(0),"^",9),SDN3=$S(SDN3="":"UNKNOWN",1:SDN3) I $D(SDCI) D NM2 Q + ; SD*5.3*439 added quit if clinic in "S" node not = to selected clinic + I '$D(SDCI),$D(^DPT(SDN1,"S",SDAP,0)),$P(^(0),"^",2)'["C",$P(^(0),"^",2)'="N",$P(^(0),"^",2)'="NA" Q:$P(^(0),U,1)'=SDC D NM2 Q + Q + ;SD*5.3*490 do not display appts prior to clinic start date +NM2 Q:$P(SDAP,".",1)<$O(^SC(SDC,"T",0)) ;SD*5.3*490 + S:$D(^DPT(SDN1,"S",SDAP,0)) ^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3)=M1_$S(($P(^DPT(SDN1,"S",SDAP,0),"^",2)["C"):"^*",SDC3="C":"^*",($P(^(0),"^",2)="N"):"^**",($P(^(0),"^",2)="NA"):"^**",1:"") + S:$D(^DPT(SDN1,"S",SDAP,0)) $P(^UTILITY($J,"SDNMS",D,SDV,SDAP,SDN2,SDN3),"^",3)=$S($P(^DPT(SDN1,"S",SDAP,0),"^",7)=4:"***",1:"") + Q + ; +CHECK ;Added SD/517 + N SDIEN,NODE,NODE0,HDFN,HDNAM,HDSN,POP + S SDIEN=0,NODE="",HDAP1=SDAP1 + F S SDIEN=$O(^SCE("B",SDAP,SDIEN)) Q:'SDIEN D + .S NODE=^SCE(SDIEN,0) + .Q:$P(NODE,U,4)'=SDC + .S HDFN=$P(NODE,U,2),HDNAM=$P(^DPT(HDFN,0),U),HDSN=$P(^(0),U,9) + .Q:$D(^UTILITY($J,"SDNMS",D,SDV,SDAP,HDNAM,HDSN)) + .S POP=0 D CHECK1 Q:POP + .S SDN1=$P(NODE,U,2),SDN2=$P(^DPT(SDN1,0),U),SDN3=$P(^DPT(SDN1,0),U,9),M1="",SDC3="" + .D NM2 + Q + ; +CHECK1 ;Added SD/517 + S HDAP1=$O(^SC(SDC,"S",SDAP,1,HDAP1)) Q:'HDAP1 + Q:'$D(^SC(SDC,"S",SDAP,1,HDAP1,0)) S NODE0=^(0) + I $P(NODE0,U,1)=HDFN S POP=1 Q + Q + ; +KILL K SDIEN,NODE,NODE0,POP,HDFN,HDNAM,HDSN,HDAP1 ;added SD/517 + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCWL2.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCWL2.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDCWL2.m (revision 623) @@ -1,31 +1,31 @@ -SDCWL2 ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99 6:41 PM - ;;5.3;Scheduling;**140,132,171,184,529**;Aug 13, 1993;Build 3 -PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7) -PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0) - I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^TMP($J,"SC",'$D(SDFL),SDCR)):^(SDCR),1:0) - S $P(^TMP($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^TMP($J,"SC",'$D(SDFL),SDCR),"^")=1 - I SDAS'["C",SDAS'="N",SDAS'="NA" S:SDS="C" $P(^(SDN),U,2)=$P(^TMP($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDCR),U,2)+1 - I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^TMP($J,"SC",1,SDCR)):^(SDCR),1:0) - Q:$D(SDFL)!(SDRT="B") S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0 - S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) - S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=1:"S",SDP=3:"S",SDP=4:"U",1:" "))="" ;added SDP=1 SD*529 - K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q - I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q - I SDAS["I" S ^("IN")=^TMP($J,1,SDN,SDAPT,"IN")+1 Q - I SDOB S ^("OB")=^TMP($J,1,SDN,SDAPT,"OB")+1 Q - I SDP=4 S ^("UN")=^TMP($J,1,SDN,SDAPT,"UN")+1 Q - S ^("SD")=^TMP($J,1,SDN,SDAPT,"SD")+1 Q -PREV S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$TR($$FMTE^XLFDT(SDBD,"2FD")," ","0"),SDEO=$TR($$FMTE^XLFDT(SDED,"2FD")," ","0"),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD - F I1=0:0 S I=$O(^TMP($J,SDSUB,1,I)) Q:I="" S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^TMP($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE - D EOP Q -COMPHEAD S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING: ",SDB1,"-",SDE1,!?26,"REPORT RUN ON: ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK - W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q -COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:" N/A",1:$J(X*100/SDOLD,7,2))," |" Q -EOP W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q -BLANK W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q -ADDON I 'SDALL&'$D(SDCL(SDSC)) Q - S J=SDOE,I=+SDOE0 - S DIV=$S($P(SDOE0,"^",11)]"":$P(SDOE0,"^",11),1:$O(^DG(40.8,0))),DFN=+$P(SDOE0,U,2) Q:'VAUTD&'$D(VAUTD(DIV)) - S $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B") S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100) - Q:$D(SDFL) S ^(SDAPT)=$S($D(^TMP($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1) - Q:'SDNAM S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q +SDCWL2 ;ALB/MLI - CONTINUATION OF CLINIC WORKLOAD REPORTS ; 07 Mar 99 6:41 PM + ;;5.3;Scheduling;**140,132,171,184**;Aug 13, 1993 +PRO S SDAS=$S($P(^SC(I,"S",J,1,K,0),U,9)="C":"C",1:$P(^DPT(DFN,"S",J,0),U,2)) S SDP=$P(^DPT(DFN,"S",J,0),U,7) +PRO1 S SDP=$P(^DPT(DFN,"S",J,0),U,7) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",'$D(SDFL),SDN)):^(SDN),1:0) + I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",'$D(SDFL),SDSC)):^(SDSC),1:0) I SDF2 S ^(SDCR)=$S($D(^TMP($J,"SC",'$D(SDFL),SDCR)):^(SDCR),1:0) + S $P(^TMP($J,"CL",'$D(SDFL),SDN),"^")=1 I SDS="S" S:SDF1 $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1 I SDF2 S $P(^TMP($J,"SC",'$D(SDFL),SDCR),"^")=1 + I SDAS'["C",SDAS'="N",SDAS'="NA" S:SDS="C" $P(^(SDN),U,2)=$P(^TMP($J,"CL",'$D(SDFL),SDN),U,2)+1 I SDS="S" S:SDF1 $P(^(SDSC),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDSC),U,2)+1 I SDF2 S $P(^(SDCR),U,2)=$P(^TMP($J,"SC",'$D(SDFL),SDCR),U,2)+1 + I $D(SDFL) S:SDS="C" ^(SDN)=$S($D(^TMP($J,"CL",1,SDN)):^(SDN),1:0) I SDS="S" S:SDF1 ^(SDSC)=$S($D(^TMP($J,"SC",1,SDSC)):^(SDSC),1:0) S:SDF2 ^(SDCR)=$S($D(^TMP($J,"SC",1,SDCR)):^(SDCR),1:0) + Q:$D(SDFL)!(SDRT="B") S SDAPT=$S(SDF="D":J\1,1:J\100) S:'$D(^TMP($J,1,SDN,SDAPT)) (^(SDAPT,"CA"),^("NS"),^("IN"),^("OB"),^("UN"),^("SD"))=0 + S TIME=$E($P(J,".",2)_"0000",1,4),TIME=$E(TIME,1,2)_":"_$E(TIME,3,4) + S:SDNAM SDPN=$E($P(^DPT(DFN,0),U),1,20),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,1,SDN,SDAPT,"NM",SDPN,SDSSN,TIME,$S(SDAS]"":SDAS,SDOB:"OB",SDP=3:"S",SDP=4:"U",1:" "))="" + K TIME I SDAS["C" S ^("CA")=^TMP($J,1,SDN,SDAPT,"CA")+1 Q + I SDAS="N"!(SDAS="NA") S ^("NS")=^TMP($J,1,SDN,SDAPT,"NS")+1 Q + I SDAS["I" S ^("IN")=^TMP($J,1,SDN,SDAPT,"IN")+1 Q + I SDOB S ^("OB")=^TMP($J,1,SDN,SDAPT,"OB")+1 Q + I SDP=4 S ^("UN")=^TMP($J,1,SDN,SDAPT,"UN")+1 Q + S ^("SD")=^TMP($J,1,SDN,SDAPT,"SD")+1 Q +PREV S SDBD=SDBD+.1,SDED=SDED-.9,SDBO=$TR($$FMTE^XLFDT(SDBD,"2FD")," ","0"),SDEO=$TR($$FMTE^XLFDT(SDED,"2FD")," ","0"),I=0,SDSUB=$S(SDS="C":"CL",1:"SC") D COMPHEAD + F I1=0:0 S I=$O(^TMP($J,SDSUB,1,I)) Q:I="" S SDCUR=+$P(^(I),"^",2),SDOLD=+$S($D(^TMP($J,SDSUB,0,I)):$P(^(I),"^",2),1:0) D:($Y>(IOSL-8)) EOP,COMPHEAD D COMPARE + D EOP Q +COMPHEAD S SDPG=SDPG+1 W @IOF,!?29,"CLINIC WORKLOAD REPORT",?71,"PAGE: ",$J(SDPG,3),!?22,"COMPARISON OF VISITS TO PREVIOUS YEAR",!?20,"FOR PERIOD COVERING: ",SDB1,"-",SDE1,!?26,"REPORT RUN ON: ",SDNOW,!! K Y S $P(Y,"_",81)="" W Y D BLANK + W !,"|",?25,"|",?29,"# OF VISITS",?43,"|",?47,"# OF VISITS",?61,"|",?64,"NET",?70,"|",?74,"%",?79,"|",!,"|",?7,$S(SDS="C":"Clinic",1:"Stop Code")," Name",?25,"|",SDB,"-",SDE,"|",SDBO,"-",SDEO,"| CHANGE | CHANGE |" D EOP,EOP,BLANK Q +COMPARE W !,"|",$S(SDS="C":$E(I,1,24),1:$J(I,15)),?25,"|",?31,$J(SDCUR,7),?43,"|",?49,$J(SDOLD,7),?61,"|" S X=SDCUR-SDOLD W $J($S(X>0:"+"_X,2:X),7,2),?70,"|",$S(SDOLD=0:" N/A",1:$J(X*100/SDOLD,7,2))," |" Q +EOP W !,"|" K Y S $P(Y,"_",25)="" W Y,"|",$E(Y,1,17),"|",$E(Y,1,17),"|",$E(Y,1,8),"|",$E(Y,1,8),"|" Q +BLANK W !,"|",?25,"|",?43,"|",?61,"|",?70,"|",?79,"|" Q +ADDON I 'SDALL&'$D(SDCL(SDSC)) Q + S J=SDOE,I=+SDOE0 + S DIV=$S($P(SDOE0,"^",11)]"":$P(SDOE0,"^",11),1:$O(^DG(40.8,0))),DFN=+$P(SDOE0,U,2) Q:'VAUTD&'$D(VAUTD(DIV)) + S $P(^TMP($J,"SC",'$D(SDFL),SDSC),"^")=1,$P(^(SDSC),"^",2)=$P(^(SDSC),"^",2)+1 Q:(SDRT="B") S ^("{")=$S($D(^(SDSC,"{")):^("{")+1,1:1),SDAPT=$S(SDF="D":I\1,1:I\100) + Q:$D(SDFL) S ^(SDAPT)=$S($D(^TMP($J,"SC",SDSC,"{",SDAPT)):^(SDAPT)+1,1:1) + Q:'SDNAM S SDNM=$P(^DPT(DFN,0),U),SDSSN=$S($P(^(0),U,9)]"":$P(^(0),U,9),1:0),^TMP($J,"SC",SDSC,"{",SDAPT,SDNM,SDSSN,I,J)="" Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDD0.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDD0.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDD0.m (revision 623) @@ -1,41 +1,41 @@ -SDD0 ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84 3:00 pm - ;;5.3;Scheduling;**167,401,529**;Aug 13, 1993;Build 3 -SETX ; - N SDDIV - S SDDIV=$P($G(SD0),"^",15) Q:SDDIV="" - I '$D(VAUTD(SDDIV)),VAUTD=0 Q - Q:'$D(^SC(SC,"SL")) S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI - S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1) - K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y - F DATE=$$FMADD^XLFDT(SDBD,-1):0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED) I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK ;changed 1st part of For loop SD*529 - Q -CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y - D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT - I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q - I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT - K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" - I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G:'SDAPPT OVR G I - G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q - S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1) -HOLIDAY S ^SC(SC,"ST",DATE,1)=" "_$E(DATE,6,7)_" "_X,^(0)=DATE -Z S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT - Q -END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q -FIX ;DH=PATTERN X=DATE - D SM G:'SDAPPT OVR -I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1) - I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR - F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0 I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999) - S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I -OVR I $L(SM)>SM S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=SC - G Z -SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q -APPT S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q - F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT) S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0 I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1) - Q -CAN S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0)) S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y="" - F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q -ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1 +SDD0 ;SF/GFT,ALB/BOK,JSH,LDB - REMAP A CLINIC ; 26 JAN 84 3:00 pm + ;;5.3;Scheduling;**167,401**;Aug 13, 1993 +SETX ; + N SDDIV + S SDDIV=$P($G(SD0),"^",15) Q:SDDIV="" + I '$D(VAUTD(SDDIV)),VAUTD=0 Q + Q:'$D(^SC(SC,"SL")) S SDSL=^("SL"),SL=+^("SL"),X=$P(SDSL,U,3),STARTDAY=$S($L(X):X,1:8),X=$P(SDSL,U,6),HSI=$S('X:4,X<3:8/X,1:2),SI=$S(X:X,1:4),SDSI=SI + S:SI=1 SI=4 S:SI=2 SI=4 S SDSOH=$S($P(SDSL,U,8)']"":0,1:1) + K SDIN,SDRE,SDRE1 N SDNODE I $D(^SC(SC,"I")) S SDIN=+^("I"),SDRE=+$P(^("I"),"^",2),Y=SDRE D DTS^SDUTL S SDRE1=Y + F DATE=SDBD-1:0 S X1=DATE,X2=1 N X D C^%DTC S DATE=X S SDNODE=$D(^SC(SC,"ST",DATE)) Q:DATE'>0!(DATE>SDED) I $S('$D(SDIN):1,'SDIN:1,SDIN>DATE:1,SDRE'>DATE&(SDRE):1,1:0) K SM,SDHOL D CHECK + Q +CHECK S X=DATE D DW^%DTC S DAY=$P("SUN^MON^TUES^WEDNES^THURS^FRI^SATUR",U,Y+1),DOW=Y + D APPT I $D(^SC(SC,"ST",DATE,1)),^(1)'[$E(DAY,1,2)&(^(1)["]") S MSG="Bogus clinic day"_$S(SDAPPT:"- Appts!",1:"") D PRNT + I $D(^SC(SC,"ST",DATE,1)),^(1)["CANCEL"!($E(^(1),$F(^(1),"["),999)?."X") S MSG="Cancelled" D PRNT Q + I $D(^HOLIDAY(DATE,0)),'SDSOH S SDHOL=1,X=$P(^(0),U,2) G HOLIDAY:'SDAPPT,Z:SDAPPT + K ^SC(SC,"ST",DATE) S SS=+$O(^SC(SC,"T"_DOW,DATE)),SB=STARTDAY-1/100,STR="{}&%?#@!$* XXWVUTSRQPONMLKJIHGFEDCBA0123456789jklmnopqrstuvwxyz" + I $D(^SC(SC,"OST",DATE,1)),^(1)]"" S (X,DR)=DATE D DOW^SDM0 S DOW=Y,SM=^SC(SC,"OST",DATE,1),SS=0 G:'SDAPPT OVR G I + G Z:'$D(^SC(SC,"T"_DOW,SS,1)) I ^(1)="" S MSG="no master pattern for this day" D:SDNODE PRNT Q + S DH=^(1),X=DATE G FIX ;NAKED REFERENCE ^SC(IFN,"T"_DOW,DATE,1) +HOLIDAY S ^SC(SC,"ST",DATE,1)=" "_$E(DATE,6,7)_" "_X,^(0)=DATE +Z S MSG=$S($D(SDHOL)&SDAPPT:"- Appts!",'SDSOH&$D(SDHOL):"- Inserted",1:"") I MSG]"" S MSG=X_MSG D PRNT + Q +END K %,%DT,DATE,DAY,DH,DOW,DR,DR1,HSI,I,P,POP,S,SB,SC,SDAPPT,SDAPPT1,SDBD,SDNM,SDED,SDHOL,SD0,SDIN,SDRE,SDRE1,SDSAVX,SDSL,SDSOH,SI,SM,SS,SD,SCI,SCC,ST,STARTDAY,STR,X,MSG,Y,YP,PG,DGVAR,DGPGM,VAUTD,VAUTC,SDU,BEGDATE,ENDDATE D CLOSE^DGUTQ Q +FIX ;DH=PATTERN X=DATE + D SM G:'SDAPPT OVR +I S I=DR#1-SB*100,I=I#1*SI\.6+(I\1*SI)*2,S=$E(SM,I,999),SM=$E(SM,1,I-1) + I $D(^SC(SC,"S",DR,"MES")) D CAN S X=SDSAVX K SDSAVX S DR=+$O(^SC(SC,"S",DR)) G:DR\1=X I G OVR + F Y=0:0 S Y=$O(^SC(SC,"S",DR,1,Y)) Q:Y'>0 I $P(^(Y,0),"^",9)'["C" S SDSL=$P(^(0),U,2)/SL*(SL\(60/SDSI))*HSI-HSI F I=0:HSI:SDSL S ST=$E(S,I+2) S:ST="" ST=" " S S=$E(S,1,I+2-1)_$E(STR,$F(STR,ST)-2)_$E(S,I+3,999) + S SM=SM_S,DR=$O(^SC(SC,"S",DR)) I DR\1=X G I +OVR I $L(SM)>SM S ^SC(SC,"ST",X,0)=X,^(1)=SM S:SS'>0 ^(9)=SC + G Z +SM S SM=$P("SU^MO^TU^WE^TH^FR^SA",U,DOW+1)_" "_$E(X,6,7)_$J("",SI+SI-6)_DH_$J("",64-$L(DH)) Q +APPT S DR=+$O(^SC(SC,"S",DATE)),SDAPPT=0 I DR>(DATE_.9) S DR=DATE Q + F DR1=DATE:0 S DR1=$O(^SC(SC,"S",DR1)) Q:DR1'>0!(DR1>(DATE+1))!(SDAPPT) S:$D(^(DR1,"MES")) SDAPPT=1 F SDAPPT1=0:0 S SDAPPT1=$O(^SC(SC,"S",DR1,1,SDAPPT1)) Q:SDAPPT1'>0 I $D(^(SDAPPT1,0)) S SDAPPT=$S($P(^(0),"^",9)="C":0,1:1) + Q +CAN S SDSAVX=X Q:'$D(^SC(SC,"SDCAN",DR,0)) S X=$E($P(DR,".",2)_"0000",1,4),I=SM_S D TT S ST=%,X=$P(^SC(SC,"SDCAN",DR,0),"^",2) D TT S I=I_$J("",%-$L(I)),Y="" + F X=0:2:% S S=$E(I,X+SI+SI),P=$S(X(IOSL-4) ESC^SDD W !,$E(SDNM,1,25),?27,$E(DAY,1,3)_" " S Y=DATE D DT^DIO2 W ?45,MSG Q +ESC S SDU=0 I $E(IOST,1,2)="C-" W *7 R ESC:DTIME S:U=ESC SDU=1 Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDLT.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDLT.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDLT.m (revision 623) @@ -1,83 +1,81 @@ -SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003 - ;;5.3;Scheduling;**185,213,281,330,398,523**;Aug 13, 1993;Build 6 - ; - ;************************************************************************** - ; MODIFICATIONS - ; - ; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES - ; -------- ---------- --------- ---------------------------------------- - ; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if - ; requested - ; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0 - ; - ;************************************************************************** - ; - ;WRITE GREETING AND OPENING TEXT OF LETTER -PRT S DFN=$P(A,U,1) ;SD*523 - I $D(SDNOSH) I $D(^DPT(DFN,.1)) S POP=1 Q:POP ;SD/523 - S Y=DT D DTS^SDUTL - I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1 - K SDFIRST - ;S SDFIRST=0 - W !,?65,Y,!,?65,$$LAST4(A),!!!! - I 'SDFORM W !!!!! D ADDR W !!!! -W1 W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ") - N DPTNAME - S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_"," - S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,"," - W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0 S X=^(Z0,0) D ^DIWP - D ^DIWW K ^UTILITY($J,"W") Q -WRAPP ;WRITE APPOINTMENT INFORMATION - S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM - S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM - S (SDX,X)=SDX1 Q -FORM S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?4,DOW,?14,$J(SDDAT,12) - W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF - Q -REST ;WRITE THE REMAINDER OF LETTER - I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0 S X=^(Z5,0) D ^DIWP - D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM - F I=$Y:1:IOSL-12 W ! - D ADDR Q -ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2 - I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")="" - S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X - D ADD^VADPT D - .;CHANGE STATE TO ABBR. - .N SDIENS,X - .I $D(^UTILITY("VAPA",$J,5)) S SDIENS=+^UTILITY("VAPA",$J,5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(^UTILITY("VAPA",$J,5),U,2)=X - .K SDIENS Q - N SDCCACT1,SDCCACT2 - S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3) - ;if confidential address is not active for scheduling/appointment letters, print to regular address - I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D - .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) - .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2) - .I ^UTILITY("VAPA",$J,11)]"" W " ",$P(^UTILITY("VAPA",$J,11),U,2) - ;if confidential address is active for scheduling/appointment letters, print to confidential address - I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D - .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) - .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2) - .I ^UTILITY("VAPA",$J,18)]"" W " ",$P(^UTILITY("VAPA",$J,18),U,2) - W ! D KVAR^VADPT Q - ; - ; -LAST4(DFN) ;Return patient "last four" - N SDX - S SDX=$G(^DPT(+DFN,0)) - Q $E(SDX)_$E($P(SDX,U,9),6,9) - ; -BADADD ;Print patients with a Bad Address Indicator - I '$D(^TMP($J,"BADADD")) Q - N SDHDR,SDHDR1 - W @IOF,$TR($J("",IOM)," ","*") - S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,! - S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR." - W !,"Last 4",!,"of SSN",?10,"Patient Name",! - W $TR($J("",IOM)," ","*") - N SDNAM,SDDFN - S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D - . S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D - . . W !,$$LAST4(SDDFN),?10,SDNAM - W !!,SDHDR1 - Q +SDLT ;ALB/LDB - CANCELLATION LETTERS ; 14 Feb 2003 + ;;5.3;Scheduling;**185,213,281,330,398**;Aug 13, 1993 + ; + ;************************************************************************** + ; MODIFICATIONS + ; + ; DATE PATCH DEVELOPER DESCRIPTION OF CHANGES + ; -------- ---------- --------- ---------------------------------------- + ; 02/14/03 SD*5.3*281 SAUNDERS Print letters to confidential address if + ; requested + ; 12/2/03 SD*5.3*330 LUNDEN Remove form feed from PRT+0 + ; + ;************************************************************************** + ; + ;WRITE GREETING AND OPENING TEXT OF LETTER +PRT S Y=DT D DTS^SDUTL + I +$G(SDFIRST)=0 W @IOF ;SD*5.3*330 Form feed only after letter #1 + K SDFIRST + ;S SDFIRST=0 + W !,?65,Y,!,?65,$$LAST4(A),!!!! + I 'SDFORM W !!!!! D ADDR W !!!! +W1 W !,"Dear ",$S($P(^DPT(+A,0),"^",2)="M":"Mr. ",1:"Ms. ") + N DPTNAME + S DPTNAME("FILE")=2,DPTNAME("FIELD")=".01",DPTNAME("IENS")=(+A)_"," + S X=$$NAMEFMT^XLFNAME(.DPTNAME,"G","M") W X,"," + W !! K ^UTILITY($J,"W"),DIWF,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z0=0:0 S Z0=$O(^VA(407.5,SDLET,1,Z0)) Q:Z0'>0 S X=^(Z0,0) D ^DIWP + D ^DIWW K ^UTILITY($J,"W") Q +WRAPP ;WRITE APPOINTMENT INFORMATION + S:$D(SC)&'$D(SDC) SDC=SC S SDCL=$P(^SC(+SDC,0),"^",1),SDCL=SDCL_" Clinic" D FORM + S SDX1=$S($D(SDX):SDX,1:X) S:$D(SDS) S=SDS F B=3,4,5 I $P(S,"^",B)]"" S SDCL=$S(B=3:"LAB",B=4:"XRAY",1:"EKG"),SDX=$P(S,"^",B) D FORM + S (SDX,X)=SDX1 Q +FORM S:$D(SDX) X=SDX S SDHX=X D DW^%DTC S DOW=X,X=SDHX X ^DD("FUNC",2,1) S SDT0=X,SDDAT=$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",$E(SDHX,4,5))_" "_+$E(SDHX,6,7)_", "_(1700+$E(SDHX,1,3)) W !?4,DOW,?14,$J(SDDAT,12) + W ?27,$J(SDT0,8)," ",SDCL I $D(SDLT)&($Y>(IOSL-8)) W @IOF + Q +REST ;WRITE THE REMAINDER OF LETTER + I SDLET W !?12 K ^UTILITY($J,"W"),DIWL,DIWR,DIWF S DIWL=1,DIWF="C80WN" F Z5=0:0 S Z5=$O(^VA(407.5,SDLET,2,Z5)) Q:Z5'>0 S X=^(Z5,0) D ^DIWP + D ^DIWW K ^UTILITY($J,"W") Q:'SDFORM + F I=$Y:1:IOSL-12 W ! + D ADDR Q +ADDR K VAHOW S DFN=+A W !?12,$$FML^DGNFUNC(DFN) S VAHOW=2 + I $D(^DG(43,1,"BT")),'$P(^("BT"),"^",3) S VAPA("P")="" + S X1=DT,X2=5 D C^%DTC I '$D(VAPA("P")) S (VATEST("ADD",9),VATEST("ADD",10))=X + D ADD^VADPT D + .;CHANGE STATE TO ABBR. + .N SDIENS,X + .I $D(^UTILITY("VAPA",$J,5)) S SDIENS=+^UTILITY("VAPA",$J,5)_",",X=$$GET1^DIQ(5,SDIENS,1),$P(^UTILITY("VAPA",$J,5),U,2)=X + .K SDIENS Q + N SDCCACT1,SDCCACT2 + S SDCCACT1=^UTILITY("VAPA",$J,12),SDCCACT2=$P($G(^UTILITY("VAPA",$J,22,2)),"^",3) + ;if confidential address is not active for scheduling/appointment letters, print to regular address + I ($G(SDCCACT1)=0)!($G(SDCCACT2)'="Y") D + .F LL=1:1:4 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) + .W:^UTILITY("VAPA",$J,4)']"" ! I ^UTILITY("VAPA",$J,5)]"" W ", ",$P(^UTILITY("VAPA",$J,5),"^",2) + .I ^UTILITY("VAPA",$J,11)]"" W " ",$P(^UTILITY("VAPA",$J,11),U,2) + ;if confidential address is active for scheduling/appointment letters, print to confidential address + I $G(SDCCACT1)=1,$G(SDCCACT2)="Y" D + .F LL=13:1:16 W:^UTILITY("VAPA",$J,LL)]"" !,?12,^UTILITY("VAPA",$J,LL) + .W:^UTILITY("VAPA",$J,16)']"" ! I ^UTILITY("VAPA",$J,17)]"" W ", ",$P(^UTILITY("VAPA",$J,17),"^",2) + .I ^UTILITY("VAPA",$J,18)]"" W " ",$P(^UTILITY("VAPA",$J,18),U,2) + W ! D KVAR^VADPT Q + ; + ; +LAST4(DFN) ;Return patient "last four" + N SDX + S SDX=$G(^DPT(+DFN,0)) + Q $E(SDX)_$E($P(SDX,U,9),6,9) + ; +BADADD ;Print patients with a Bad Address Indicator + I '$D(^TMP($J,"BADADD")) Q + N SDHDR,SDHDR1 + W @IOF,$TR($J("",IOM)," ","*") + S SDHDR="BAD ADDRESS INDICATOR LIST" W !,?(IOM-$L(SDHDR)/2),SDHDR,! + S SDHDR1="** THE LETTER FOR THESE PATIENT(S) DID NOT PRINT DUE TO A BAD ADDRESS INDICATOR." + W !,"Last 4",!,"of SSN",?10,"Patient Name",! + W $TR($J("",IOM)," ","*") + N SDNAM,SDDFN + S SDNAM="" F S SDNAM=$O(^TMP($J,"BADADD",SDNAM)) Q:SDNAM="" D + . S SDDFN=0 F S SDDFN=$O(^TMP($J,"BADADD",SDNAM,SDDFN)) Q:'SDDFN D + . . W !,$$LAST4(SDDFN),?10,SDNAM + W !!,SDHDR1 + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDN1.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDN1.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDN1.m (revision 623) @@ -1,42 +1,42 @@ -SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84 4:34 pm - ;;5.3;Scheduling;**330,340,398,455,523**;Aug 13, 1993;Build 6 - N SDBAD - I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0 F C=0:0 S C=$O(^(A,C)) Q:C'>0 S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL - S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST -BC K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))="" - I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0 D:$D(SDLT) LT D CHECK1 I $T D OVER - I $D(VAUTC),'VAUTC G LST -LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0 D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER -LST N SDFIRST S SDFIRST=1 - F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0 F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0 I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) N POP S POP=0 D ^SDLT Q:POP D WR ;SD*523 added quit - I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0 F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0 Q:$$BADADR^DGUTL3(A) W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT - W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!! - I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD") - G END -OVER S GDATE=SDT Q:'$D(^SC(C,"S")) F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999)) F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K="" I $D(^(K,0)) S DFN=+^(0) D CHECK - Q -END K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B - K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP - K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q -CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D - .D BAD Q:SDBAD - .D SET - Q ;above logic changed SD*5.3*455 -SET I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q - S ^UTILITY($J,"NO",DFN,GDATE)=C Q -CHECK1 S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0) - Q -WR K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J="" S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1 - D:SDR SDR D REST^SDLT Q -SDR W !!,"The appointment(s) have been rescheduled as follows:",! - F J=0:0 S J=$O(CNN(J)) Q:J="" S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT - Q -SET1 S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q - Q -LT S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR") - Q -NDT W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q -KLL K ^UTILITY($J,A,C) Q -BAD S SDBAD=$$BADADR^DGUTL3(+DFN) - S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)="" - Q +SDN1 ;BSN/GRR - NO-SHOW LETTERS ; 17 AUG 84 4:34 pm + ;;5.3;Scheduling;**330,340,398,455**;Aug 13, 1993 + N SDBAD + I ANS["Y"&($D(C)) F A=0:0 S A=$O(^UTILITY($J,A)) Q:A'>0 F C=0:0 S C=$O(^(A,C)) Q:C'>0 S SC=+^(C),SDLET="" S:$D(^SC(SC,"LTR")) SDLET=+^("LTR") S:SDLET ^UTILITY($J,"SDLT",SDLET,A,C)=^UTILITY($J,A,C) S:'SDLET ^UTILITY($J,"NO",A,C)=SC D KLL + S SDFORM=$S($D(^DG(40.8,SDV1,"LTR")):^("LTR"),1:"") G:ANS["Y"&($D(C)) LST +BC K:$D(SDLT) C S:$D(SDLT) SDT=SDBD,DATEND=SDED K ^UTILITY($J) I $D(C) K VAUTC S (VAUTC,VAUTC(C))="" + I $D(VAUTC),'VAUTC F C=0:0 S C=$O(VAUTC(C)) Q:C'>0 D:$D(SDLT) LT D CHECK1 I $T D OVER + I $D(VAUTC),'VAUTC G LST +LST1 F C=0:0 S C=$O(^SC(C)) Q:C'>0 D LT,CHECK1 I $T,$S(SDV1="":1,SDV=SDV1:1,SDV="":1,1:0),'$D(SDVAUTC(+C)),$D(^SC(C,"S")) D OVER +LST N SDFIRST S SDFIRST=1 + F SDLET=0:0 S SDLET=$O(^UTILITY($J,"SDLT",SDLET)) Q:SDLET'>0 F A=0:0 S A=$O(^UTILITY($J,"SDLT",SDLET,A)) Q:A'>0 I $S('$D(^DPT(A,.35)):1,$P(^(.35),"^",1)']"":1,1:0) D ^SDLT,WR + I $D(^UTILITY($J,"NO")) W @IOF F A=0:0 S A=$O(^UTILITY($J,"NO",A)) Q:A'>0 F A1=0:0 S A1=$O(^(A,A1)) Q:A1'>0 Q:$$BADADR^DGUTL3(A) W !,$P(^DPT(A,0),"^")," ",$P(^(0),"^",9)," has failed to keep the following appointment(s):" D NDT + W:$D(^UTILITY($J,"NO")) !,"However, there are no letters assigned to the clinic(s).",!! + I $D(^TMP($J,"BADADD")) D BADADD^SDLT K ^TMP($J,"BADADD") + G END +OVER S GDATE=SDT Q:'$D(^SC(C,"S")) F J=0:0 S GDATE=$O(^SC(C,"S",GDATE)) Q:GDATE=""!(GDATE>(DATEND+.9999)) F K=0:0 S K=$O(^SC(C,"S",GDATE,1,K)) Q:K="" I $D(^(K,0)) S DFN=+^(0) D CHECK + Q +END K %,%DT,%IS,A,A0,A1,A2,ALL,ALS,ANS,BY,C,CDATE,DA,DFN,DGPGM,DGVAR,DH,DHD,DIC,DIS,DIV,DIW,DIWF,DIWL,DIWR,DIWT,DO,DOW,DN,DUPE,FLDS,F,F1,FR,GDATE,I,I1,L,L0,LET,MAX,MESS,MIN,NOAP,P,POP,SC,SD,SDFOR,SDLET,SDTIME,SI,SL,SS,ST,SDSTRTDT,TO,X,Y,ADDR,B + K CLIN,HX,LL,PDAT,S,TIME,Z,D,NDATE,ENDATE,J,SDMDT,SDMSTIME,X1,X2,SDTADE,SDADTB,SDRE,SDRE1,SDIN,SDIS,SDYES,CNN,SDT,DATEND,SDV1,K,SDR,SDJ1,^UTILITY($J),SD1,SD2,SDADD,SDC,SDCL,SDCMAX,SDCONS,SDD,SDDAT,SDDIF,SDDT,SDED,SDFORM,SDHX,SDINP,SDIP + K %ZIS,Y1,SDBD,SDCT,SDVAUTC,VAUTC,SDX,SDX1,SDNOSH,SDLT1,SDMSG,SDNODE,SDQ,SDRT,SDSOH,SDSTAT,SDT0,SDZSC,SM,SM1,STARTDAY,STIME,SDV,Z0,Z5 D CLOSE^DGUTQ Q +CHECK I $S('$D(^DPT(DFN,.35)):1,$P(^(.35),"^",1)']"":1,1:0),$D(^DPT(DFN,"S",GDATE,0)),$S($P(^(0),U,2)="N":1,$P(^(0),U,2)="NA":1,$D(SDCP)&$P(^(0),"^",2)["C":1,1:0),$P(^(0),"^",14)=SDTIME!(SDTIME="*"),'$D(^DPT(DFN,.1)) D + .D BAD Q:SDBAD + .D SET + Q ;above logic changed SD*5.3*455 +SET I SDLT1!SDLET S ^UTILITY($J,"SDLT",$S(SDLT1:SDLT1,1:SDLET),DFN,GDATE)=C_"^"_$P(^DPT(DFN,"S",GDATE,0),"^",10) Q + S ^UTILITY($J,"NO",DFN,GDATE)=C Q +CHECK1 S SDV=$P(^SC(C,0),"^",15) I $P(^(0),"^",3)="C",$S('$D(^SC(C,"I")):1,'(+^("I")):1,+^("I")>DATEND:1,+$P(^("I"),"^",2)'>DATEND&(+$P(^("I"),"^",2)):1,1:0) + Q +WR K CNN F J=0:0 S J=$O(^UTILITY($J,"SDLT",SDLET,A,J)) Q:J="" S SDR=0,SDX=J,CNN(J)=^(J),CLIN=$P(^SC(+$P(CNN(J),"^",1),0),"^",1),SDC=+CNN(J),S=$S($D(^DPT(A,"S",J,0)):^(0),1:"") D WRAPP^SDLT,SET1 + D:SDR SDR D REST^SDLT Q +SDR W !!,"The appointment(s) have been rescheduled as follows:",! + F J=0:0 S J=$O(CNN(J)) Q:J="" S SDX=$P(CNN(J),"^",2),SDC=$P(CNN(J),"^") I SDX S S=$S($D(^DPT(A,"S",SDX,0)):^(0),1:"") D WRAPP^SDLT + Q +SET1 S:'SDR SDR=$S($P(CNN(J),"^",2)]"":1,1:0) Q + Q +LT S:'SDLT1 SDLET=0 I $D(^SC(C,"LTR")),^("LTR") S SDLET=+^("LTR") + Q +NDT W !?15,$P(^SC(+^UTILITY($J,"NO",A,A1),0),"^")," on " S Y=A1 D DT^DIQ Q +KLL K ^UTILITY($J,A,C) Q +BAD S SDBAD=$$BADADR^DGUTL3(+DFN) + S:SDBAD ^TMP($J,"BADADD",$P(^DPT(+DFN,0),"^"),+DFN)="" + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDNOS0.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDNOS0.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDNOS0.m (revision 623) @@ -1,74 +1,73 @@ -SDNOS0 ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM - ;;5.3;Scheduling;**20,194,410,517,523**;Aug 13, 1993;Build 6 - D END1^SDNOS - S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV - I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) S SDV1=1 - I SDDIV'="A" S (^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 - I SDDIV="A" D DIVRPT - I SDCL(1)="ALL" S SDCL=0 D SDCL - I SDCL(1)'="ALL" F SDSUB=0:0 S SDSUB=$O(SDCL(SDSUB)) Q:SDSUB="" S SDCL=SDCL(SDSUB),SDLAB=$S(SDCL?.N1"*".E:"RANGE",1:"SDTST") D @SDLAB - S (P1,SDTOT,SDTOT1)=0,DGTCH="NO-SHOW REPORT^CLINIC^PAGE#",(SDEND,SDHD)=0 - D ^SDNOS1 - Q - ; -DIVRPT F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV S (^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 - Q - ; -SDCL F SDZ=1:1 S SDCL=$O(^SC(SDCL)) Q:'SDCL D SDTST - Q - ; -SDTST S SDNM=0,SDCL1=^SC(SDCL,0) I $P(SDCL1,U,3)'="C" Q - I SDDIVO,SDCL(1),'$D(SDR1) D DATES Q - I $S((SDDIVO&'SDCL(1)&(SDDIVO=$P(SDCL1,U,15))):1,'SDDIVO:1,$D(SDR1)&SDDIVO&($P(SDCL1,U,15)=SDDIVO):1,'$P(SDCL1,U,15)&(SDDIVO=$P(^DG(43,1,"GL"),U,3)):1,'SDV1:1,1:0) S SDIN=0 D:$D(^SC(SDCL,"I")) INAC^SDNOS1A Q:SDIN D DATES - Q - ; -DATES S:'SDDIVO SDDIV=$S($P(SDCL1,U,15)&SDV1:$P(SDCL1,U,15),$D(^DG(43,"GL")):$P(^("GL"),U,3),1:$O(^DG(40.8,0))) - Q:$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=0 - S (SDEN,SDBEG)=0,SDBEG1=SDBD F SDZ1=1:1 S SDBEG1=$O(^SC(SDCL,"S",SDBEG1)) Q:SDBEG1'>0 D SDED Q:SDBEG!SDEN D CHK - S ^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")=SDNM+^UTILITY($J,"SDNO",SDDIV,"***SDNMS***") - Q - ; -SDED S SDBEG=0,SDEN=0 I $D(SDED),(SDBEG1>(SDED+.99999)) S SDEN=1 Q - I '$D(SDED),(SDBEG1>(SDBD+.99999)) S SDBEG=1 Q - Q - ;Added 2nd Quit below SD/517 - ;SD/523 - added Q:SDPAT="" to For loop -CHK S SDAPP=0 F S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP Q:'$D(^(SDAPP,0)) I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) Q:SDPAT="" I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1 - Q - ; -CHK1 S SD="SD" F SDCHK=1,2,10,12,14 S @(SD_SDCHK)=$P(^DPT(SDPAT,"S",SDBEG1,0),U,SDCHK) - S:'SDDIVO&$P(SDCL1,U,15) SDDIV=$P(SDCL1,U,15) S:'SDDIVO&'$P(SDCL1,U,15) SDDIV=$O(^DG(40.8,0)) - S:'$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0 - I SDFMT=1 D - .I (SD2="N")!(SD2="NA"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(^DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D - ..D SET,TOTAL Q - I SDFMT=2 D - .I (SD2=""&('$D(^SC(SDCL,"S",SDBEG1,1,SDAPP,"C"))))!(SD2="N")!(SD2="NA")!(SD2="NT"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D - ..D SET,TOTAL Q - I SD2'["C" S SDNM=SDNM+1,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=SDNM - Q - ; -SET S:$P(SDCL1,U,15)&SDDIVO&SDV1 SDDIV=$P(SDCL1,U,15) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),SDBEG1,$P(^DPT(SDPAT,0),U),+$P(^(0),U,9))=SD2_U_SD10_U_SD12 - Q - ; -TOTAL S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")+1,1:1) - S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")):^("***TOT***")+1,1:1) - S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")+1,1:1) - S ^("***TOT***")=^UTILITY($J,"SDNO",SDDIV,"***TOT***")+1,^("***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")+1,1:1) - Q - ; -RANGE S SDREST=$E(SDCL,$F(SDCL,"*"),$L(SDCL)),SDCL=$E(SDCL,1,($F(SDCL,"*")-2)),SDCL1=^SC(SDCL,0) - S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) - S SDR1=1,SDR=$P(SDCL1,U) D SDTST K SDR1 - S SDREST="1"_""""_SDREST_""""_".E" F SDCXX=1:1 S SDR=$O(^SC("B",SDR)) Q:'(SDR?@SDREST)!(SDR="") S SDCL=$O(^SC("B",SDR,-1)) S SDR1=1 D RANGE1 K SDR1 - Q - ; -RANGE1 S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) D SDTST - Q - ; -NOSHOW(DFN,SDT,CIFN,PAT,DA) ;Input: DFN=Patient IFN, SDT=Appointment D/T - ; CIFN=Clinic IFN, PAT=Zero node of pat. appt., DA=Clinic appt. IFN - ; Output: 1 or 0 for noshow yes/no - N NSQUERY,NS S NS=1,NSQUERY=$$STATUS^SDAM1(DFN,SDT,CIFN,PAT,DA) - I $P(NSQUERY,";",3)["ACTION REQ" S NS=0 -NOSHOWQ Q NS +SDNOS0 ;ALB/LDB - NO SHOW REPORT ; 07 May 99 10:21 AM + ;;5.3;Scheduling;**20,194,410,517**;Aug 13, 1993;Build 4 + D END1^SDNOS + S (SDV1,SDIN,SDNM,SDNM1)=0,SDDIVO=SDDIV + I $D(^DG(43,1,"GL")),$P(^("GL"),U,2) S SDV1=1 + I SDDIV'="A" S (^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 + I SDDIV="A" D DIVRPT + I SDCL(1)="ALL" S SDCL=0 D SDCL + I SDCL(1)'="ALL" F SDSUB=0:0 S SDSUB=$O(SDCL(SDSUB)) Q:SDSUB="" S SDCL=SDCL(SDSUB),SDLAB=$S(SDCL?.N1"*".E:"RANGE",1:"SDTST") D @SDLAB + S (P1,SDTOT,SDTOT1)=0,DGTCH="NO-SHOW REPORT^CLINIC^PAGE#",(SDEND,SDHD)=0 + D ^SDNOS1 + Q + ; +DIVRPT F SDDIV=0:0 S SDDIV=$O(^DG(40.8,SDDIV)) Q:'SDDIV S (^UTILITY($J,"SDNO",SDDIV,"***N***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***NA***","***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***TOT***"),^UTILITY($J,"SDNO",SDDIV,"***SDNMS***"))=0 + Q + ; +SDCL F SDZ=1:1 S SDCL=$O(^SC(SDCL)) Q:'SDCL D SDTST + Q + ; +SDTST S SDNM=0,SDCL1=^SC(SDCL,0) I $P(SDCL1,U,3)'="C" Q + I SDDIVO,SDCL(1),'$D(SDR1) D DATES Q + I $S((SDDIVO&'SDCL(1)&(SDDIVO=$P(SDCL1,U,15))):1,'SDDIVO:1,$D(SDR1)&SDDIVO&($P(SDCL1,U,15)=SDDIVO):1,'$P(SDCL1,U,15)&(SDDIVO=$P(^DG(43,1,"GL"),U,3)):1,'SDV1:1,1:0) S SDIN=0 D:$D(^SC(SDCL,"I")) INAC^SDNOS1A Q:SDIN D DATES + Q + ; +DATES S:'SDDIVO SDDIV=$S($P(SDCL1,U,15)&SDV1:$P(SDCL1,U,15),$D(^DG(43,"GL")):$P(^("GL"),U,3),1:$O(^DG(40.8,0))) + Q:$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=0 + S (SDEN,SDBEG)=0,SDBEG1=SDBD F SDZ1=1:1 S SDBEG1=$O(^SC(SDCL,"S",SDBEG1)) Q:SDBEG1'>0 D SDED Q:SDBEG!SDEN D CHK + S ^UTILITY($J,"SDNO",SDDIV,"***SDNMS***")=SDNM+^UTILITY($J,"SDNO",SDDIV,"***SDNMS***") + Q + ; +SDED S SDBEG=0,SDEN=0 I $D(SDED),(SDBEG1>(SDED+.99999)) S SDEN=1 Q + I '$D(SDED),(SDBEG1>(SDBD+.99999)) S SDBEG=1 Q + Q + ;Added 2nd Quit below SD/517 +CHK S SDAPP=0 F S SDAPP=$O(^SC(SDCL,"S",SDBEG1,1,SDAPP)) Q:'SDAPP Q:'$D(^(SDAPP,0)) I $D(^SC(SDCL,"S",SDBEG1,1,SDAPP))=10,$P(^(SDAPP,0),U,9)'="C" S SDPAT=$P(^SC(SDCL,"S",SDBEG1,1,SDAPP,0),U,1) I $D(^DPT(SDPAT,"S",SDBEG1)) D CHK1 + Q + ; +CHK1 S SD="SD" F SDCHK=1,2,10,12,14 S @(SD_SDCHK)=$P(^DPT(SDPAT,"S",SDBEG1,0),U,SDCHK) + S:'SDDIVO&$P(SDCL1,U,15) SDDIV=$P(SDCL1,U,15) S:'SDDIVO&'$P(SDCL1,U,15) SDDIV=$O(^DG(40.8,0)) + S:'$D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")) ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=0 + I SDFMT=1 D + .I (SD2="N")!(SD2="NA"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(^DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D + ..D SET,TOTAL Q + I SDFMT=2 D + .I (SD2=""&('$D(^SC(SDCL,"S",SDBEG1,1,SDAPP,"C"))))!(SD2="N")!(SD2="NA")!(SD2="NT"),$$NOSHOW(SDPAT,SDBEG1,SDCL,$G(DPT(SDPAT,"S",SDBEG1,0)),SDAPP) D + ..D SET,TOTAL Q + I SD2'["C" S SDNM=SDNM+1,^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***SDNMS***")=SDNM + Q + ; +SET S:$P(SDCL1,U,15)&SDDIVO&SDV1 SDDIV=$P(SDCL1,U,15) S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),SDBEG1,$P(^DPT(SDPAT,0),U),+$P(^(0),U,9))=SD2_U_SD10_U_SD12 + Q + ; +TOTAL S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***"_SD2_"***","***TOT***")+1,1:1) + S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),$P(SDBEG1,"."),"***"_SD2_"***","***TOT***")):^("***TOT***")+1,1:1) + S ^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")):^UTILITY($J,"SDNO",SDDIV,$P(SDCL1,U),"***TOT***")+1,1:1) + S ^("***TOT***")=^UTILITY($J,"SDNO",SDDIV,"***TOT***")+1,^("***TOT***")=$S($D(^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")):^UTILITY($J,"SDNO",SDDIV,"***"_SD2_"***","***TOT***")+1,1:1) + Q + ; +RANGE S SDREST=$E(SDCL,$F(SDCL,"*"),$L(SDCL)),SDCL=$E(SDCL,1,($F(SDCL,"*")-2)),SDCL1=^SC(SDCL,0) + S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) + S SDR1=1,SDR=$P(SDCL1,U) D SDTST K SDR1 + S SDREST="1"_""""_SDREST_""""_".E" F SDCXX=1:1 S SDR=$O(^SC("B",SDR)) Q:'(SDR?@SDREST)!(SDR="") S SDCL=$O(^SC("B",SDR,-1)) S SDR1=1 D RANGE1 K SDR1 + Q + ; +RANGE1 S:'SDDIVO SDDIV=$S($P(SDCL1,U,15):$P(SDCL1,U,15),'$P(SDCL1,U,15)&$D(^DG(43,"GL")):$P(^DG(43,"GL"),U,3),1:$O(^DG(40.8,0))) D SDTST + Q + ; +NOSHOW(DFN,SDT,CIFN,PAT,DA) ;Input: DFN=Patient IFN, SDT=Appointment D/T + ; CIFN=Clinic IFN, PAT=Zero node of pat. appt., DA=Clinic appt. IFN + ; Output: 1 or 0 for noshow yes/no + N NSQUERY,NS S NS=1,NSQUERY=$$STATUS^SDAM1(DFN,SDT,CIFN,PAT,DA) + I $P(NSQUERY,";",3)["ACTION REQ" S NS=0 +NOSHOWQ Q NS Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA00.m (revision 623) @@ -1,198 +1,196 @@ -SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission ; 11/2/04 11:09am ; 2/24/08 11:25am - ;;5.3;Scheduling;**290,333,349,376,491**;Aug 13,1993;Build 53 - ;SD/491 - calling SRPA03 instead of SDRPA04 (dupl) - Q -EN ;manual entry - N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC - I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q - S RUNID=$O(^SDWL(409.6,":"),-1) - I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q - K ZTSK N SDCON S SDCON=1 - S %DT("A")="Queue to run: " - S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1 Q:'SDCON - .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO="" - .S ZTDESC="PAIT" - .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D - ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and use SD-PAIT REPAIR to fix the run." - .Q:'SDCON - .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) - .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!" - I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q - W !!,"Task number: ",ZTSK,! - Q -START ;Tasked entry - N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN - I '$$RUNCK^SDRPA02() Q ;check scheduling - I $G(ZTSK)="" D Q - . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!! - S ZTSKN=ZTSK - S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run - I SDPR N SD1 S SD1=0 D Q:SD1 ;finish if task is still running - .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q ; previous task finished - .N ZTSK - .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1 - .;send message - .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ - .S XMSUB="PAIT BACKGROUND JOB" - .S XMY("G.SD-PAIT")="" - .S XMTEXT="SDAMX(" - .S XMDUZ="POSTMASTER" - .S SDAMX(1)="The PAIT requested task has been terminated." - .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed." - .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)="" - .E S SD1=2 D - ..S SDAMX(3)="The previous run errored out, not repaired!" - ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run." - .D ^XMD - S DIC=409.6,DIC(0)="X" - D NOW^%DTC S TODAY=X - K DO D FILE^DICN - S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE - ;send START message - D STMES - S (SDOUT,SDCNT)=0 - K ^TMP("SDDPT",$J) - N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,"")) - S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^") - I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run - E S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ; - N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0 - S SDDAM=SDPREV ;creation date - D NOW^%DTC S TODAY=X - F S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM="" Q:SDDAM=TODAY!SDOUT D - .N DFN S DFN=0 - .F S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT D - ..N SDADT S SDADT=0 ;appt date/time - ..S SDADT=0 - ..F S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT D - ...I SDADT'>3030000 Q ;only appointment scheduled for 2003 and later; sd/491 - ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q ;compare creation dates - ...; Check for 'stop task' request - ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q - ....N DA,DIE,DR,SDD,SDLAST D - ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1 - ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE - ...N SDCL,SDSTAT,SDSTTY - ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") - ...Q:SDCL="" ; If this happens, there's something wrong. - ...; - ...; Check status. - ...; Appoinment made only before Sep 1, 2003 - ...; If it is not the first run, send but don't create a pending file - ...; Otherwise add to pending file. - ...D NOW^%DTC N STODAY S STODAY=X - ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1) - ...I $P(SDSTAT,"^")=0 Q - ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter - ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) - ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831) ; pending and final from 09/01/2003, previously 90 days - ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q ; skip non-count if not matching count and scheduled date already expired - ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U) - ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. - ...N DIC,DA,X,SDRET D - ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") - ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" - ....K DO S X=DFN D FILE^DICN - ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE - ....Q - ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) - ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) - ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 - Q:SDOUT - N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day - S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE - ; scan the previous runs - S RUNID=0 - F S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT D - .N APPTID,SDADT,REC - .S APPTID=0 - .;scanning only appointments that were sent as 'pending' - .F S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D - ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q ;anticipate - ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2) - ..;evaluate SDADT - appt date/time for possible removal from sending - ..I SDADT'>3030000 N DIK S DIK="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID,DA=APPTID D ^DIK ;delete entry; not to be sent; sd/491 - ..; Check for 'stop task' - ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q ; - ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO - ..S SDCLO=$P(REC,"^",10) - ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw - ..I SDDAMO="" D - ...N SDD S SDD=9999999 F S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0 I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q - ..Q:SDDAMO="" ;cannot determine what was original creation date - ..;evaluate if the same creation date - ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") - ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") - ..Q:SDCL="" ; - ..I SDCLO="" S SDCLO=SDCL - ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent - ..; Check status. If it is a termination, continue. - ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT)) ; overridden to be process next time - ..;anothercross reference entry will be created; do not need to quit - ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID))) ;see above - ..S SDSTAT="" - ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D - ...; create CT status; the current SDADT has different creation date - ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO - ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0) - ..I $P(SDSTAT,"^")=0 Q - ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) - ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL - ..S SDSTTY=$P(SDSTAT,U,2) - ..I SDSTTY="P"&(SDREJ="") Q ;do not send in pending status if not rejected ;esw - ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. - ..N DIC,DA,X D - ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") - ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" - ...K DO S X=DFN D FILE^DICN - ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE - ..N DIC,DA D - ...; not rejected can be sent only as 'S'- sent as final - ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final - ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID - ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE - ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) - ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) - ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 - .Q - Q:SDOUT - I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) - K ^TMP("SDDPT",$J) - D MSGT^SDRPA04(CRUNID,SDPEN,SDFIN) - Q -STMES ;generate start message - N SDS,SD870,SD87 - S SD870=$O(^HLCS(870,"B","SD-PAIT","")) - N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY") - N SD87 S SD87=SD870_"," - S SDSTAT=ARRAY(870,SD87,4,"I") - D NOW^%DTC - N SDDT,SDST S SDDT=% - S SDST=$P($$SITE^VASITE(),"^",3) - N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ - S XMSUB=$G(SDST)_" - PAIT START JOB" - S XMY("G.SD-PAIT")="" - S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" - S XMTEXT="SDAMX(" - S XMDUZ="POSTMASTER" - S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK - S SDAMX(2)="Site Started SD-PAIT status Task #" - S SDAMX(3)=SDST_" |"_SDDT_" |"_SDSTAT_" |"_ZTSK - ; - I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D - .S SDAMX(4)=" Please start a REMEDY ticket for station "_SDST - .S SDAMX(5)="SD-PAIT Logical Link has to be started." - .S SDAMX(6)="Refer the ticket to Scheduling PAIT." - .S SDAMX(7)="" - D ^XMD - Q - ; -GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs. - ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called. - ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd - D ^%DTC - Q X>0 ; -STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals - I SDSTTY="F" S SDFIN=SDFIN+1 Q - I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1 - Q +SDRPA00 ;BP-OIFO/OWAIN,ESW - Patient Appointment Information Transmission ; 11/2/04 11:09am + ;;5.3;Scheduling;**290,333,349,376**;Aug 13,1993 + Q +EN ;manual entry + N SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE,RUNID,REC + I '$$RUNCK^SDRPA02() W !,"You attempted to start PAIT outside the authorized transmission dates.",!,"Job has been terminated.",! Q + S RUNID=$O(^SDWL(409.6,":"),-1) + I RUNID S ZTSK=$P(^SDWL(409.6,RUNID,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"A task is currently active." Q + K ZTSK N SDCON S SDCON=1 + S %DT("A")="Queue to run: " + S %DT="AEFXR" W ! D ^%DT S DT=Y D:Y'=-1 Q:'SDCON + .S ZTDTH=Y,ZTRTN="START^SDRPA00",ZTIO="" + .S ZTDESC="PAIT" + .I RUNID I $P(^SDWL(409.6,RUNID,0),U,7)="" S SDCON=0 D + ..W !,"The previous run errored out, not repaired!",!,"Please address a problem and then use option SD-PAIT REPAIR to fix the run." + .Q:'SDCON + .F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK) + .I $G(ZTSK) W !,"Task # "_ZTSK_" queued!" + I '$G(ZTSK) W !!,"Task not queued, check Taskman",! Q + W !!,"Task number: ",ZTSK,! + Q +START ;Tasked entry + N SDOUT,DFN,DFNEND,SDCNT,SDCNT0,RUNID,RUNDT,SDPREV,FIRST,SDDAM,TODAY,SD6A,SD8A,SD68,RUNIDP,SDPR,ZTSKN + I '$$RUNCK^SDRPA02() Q ;check scheduling + I $G(ZTSK)="" D Q + . W !,"NOT AN INTERACTIVE OPTION...schedule through TaskMan",!! + S ZTSKN=ZTSK + S SDPR=$O(^SDWL(409.6,":"),-1) ;previous run + I SDPR N SD1 S SD1=0 D Q:SD1 ;finish if task is still running + .I $P(^SDWL(409.6,SDPR,0),U,7)'="" Q ; previous task finished + .N ZTSK + .S ZTSK=$P(^SDWL(409.6,SDPR,0),"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) S SD1=1 + .;send message + .N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ + .S XMSUB="PAIT BACKGROUND JOB" + .S XMY("G.SD-PAIT")="" + .S XMTEXT="SDAMX(" + .S XMDUZ="POSTMASTER" + .S SDAMX(1)="The PAIT requested task has been terminated." + .S SDAMX(2)="The previous task #: "_ZTSK_" run #: "_SDPR_" has not been completed." + .I SD1=1 S SDAMX(3)="It is still running.",SDAMX(4)="" + .E S SD1=2 D + ..S SDAMX(3)="The previous run errored out, not repaired!" + ..S SDAMX(4)="Address a problem and use option SD-PAIT REPAIR to fix the run." + .D ^XMD + S DIC=409.6,DIC(0)="X" + D NOW^%DTC S TODAY=X + K DO D FILE^DICN + S DA=+Y,DIE=DIC,DR="1///"_ZTSK D ^DIE + ;send START message + D STMES + S (SDOUT,SDCNT)=0 + K ^TMP("SDDPT",$J) + N CRUNID S CRUNID=$O(^SDWL(409.6,"AD",ZTSK,"")) + S RUNDT=$P(^SDWL(409.6,CRUNID,0),"^") + I SDPR=0 S SDPREV=3020831,FIRST=1 ;first run + E S SDPREV=$P(^SDWL(409.6,SDPR,0),U,4),FIRST=0 ; + N SDFIN,SDPEN,SDF,SDTR S (RUNID,SDFIN,SDPEN,SDTR,SDF)=0 + S SDDAM=SDPREV ;creation date + D NOW^%DTC S TODAY=X + F S SDDAM=$O(^DPT("ASADM",SDDAM)) Q:SDDAM="" Q:SDDAM=TODAY!SDOUT D + .N DFN S DFN=0 + .F S DFN=$O(^DPT("ASADM",SDDAM,DFN)) Q:+DFN'=DFN!SDOUT D + ..N SDADT S SDADT=0 ;appt date/time + ..S SDADT=0 + ..F S SDADT=$O(^DPT("ASADM",SDDAM,DFN,SDADT)) Q:+SDADT'=SDADT!SDOUT D + ...I SDDAM'=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") Q ;compare creation dates + ...; Check for 'stop task' request + ...S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT D N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q + ....N DA,DIE,DR,SDD,SDLAST D + ....S SDLAST=$O(^SDWL(409.6,CRUNID,1,"B"),-1) S SDD=$P(^SDWL(409.6,CRUNID,1,SDLAST,0),U,7)-1 + ....S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE + ...N SDCL,SDSTAT,SDSTTY + ...S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") + ...Q:SDCL="" ; If this happens, there's something wrong. Do we need to handle exceptions like this? + ...; + ...; Check status. + ...; If the appointment is finalized and it is the first run, do not send if the date appoinment made is before Sep 1, 2003 + ...; If it is not the first run, send but don't create a pending file + ...; Otherwise add to pending file. + ...D NOW^%DTC N STODAY S STODAY=X + ...S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,STODAY,1) + ...I $P(SDSTAT,"^")=0 Q + ...N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL ;assign a new clinic if from matching non count with encounter + ...S SDSTTY=$P(SDSTAT,U,2),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) + ...I SDSTTY="F" Q:'$$GT90DAYS(SDDAM,3030831) ; pending and final from 09/01/2003, previously 90 days + ...I SDSTTY="F",SD6A="NM",SD8A="NC" Q ; skip non-count if not matching count and scheduled date already expired + ...N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U) + ...N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. + ...N DIC,DA,X,SDRET D + ....N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") + ....S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" + ....K DO S X=DFN D FILE^DICN + ....S DA=+Y,DIE=DIC,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE + ....Q + ...D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) + ...S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) + ...S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 + Q:SDOUT + N SDD S SDD=$O(^DPT("ASADM",TODAY),-1) ;enter the last scanned day + S DA=CRUNID,DIE=409.6,DR="1.2///"_SDD D ^DIE + ; scan the previous runs + S RUNID=0 + F S RUNID=$O(^SDWL(409.6,RUNID)) Q:+RUNID=CRUNID!SDOUT D + .N APPTID,SDADT,REC + .S APPTID=0 + .;scanning only appointments that were sent as 'pending' + .F S APPTID=$O(^SDWL(409.6,"AE","Y",RUNID,APPTID)) Q:APPTID=""!SDOUT S REC=$G(^SDWL(409.6,RUNID,1,APPTID,0)) D + ..IF REC="" K ^SDWL(409.6,"AE","Y",RUNID,APPTID) Q ;anticipate + ..S DFN=$P(REC,"^"),SDADT=$P(REC,"^",2) + ..; Check for 'stop task' + ..S SDCNT=SDCNT+1 I SDCNT#500=0 S SDOUT=$$S^%ZTLOAD I SDOUT N SDBCID,SDMCID,SDSTOP D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) S SDSTOP=1 D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN,,SDSTOP) K ^TMP("SDDPT",$J) Q ; + ..N SDCL,SDCLO,SDCE,SDSTAT,SDREJ,SDDAM,SDDAMO + ..S SDCLO=$P(REC,"^",10) + ..S SDREJ=$P(REC,"^",8),SDDAMO=$P(REC,"^",7) ;esw + ..I SDDAMO="" D + ...N SDD S SDD=9999999 F S SDD=$O(^DPT("ASADM",SDD),-1) Q:SDD'>0 I $D(^DPT("ASADM",SDD,DFN,SDADT)) S SDDAMO=SDD Q + ..Q:SDDAMO="" ;cannot determine what was original creation date + ..;evaluate if the same creation date + ..S SDDAM=$$GET1^DIQ(2.98,SDADT_","_DFN_",",20,"I") + ..S SDCL=$$GET1^DIQ(2.98,SDADT_","_DFN_",",.01,"I") + ..Q:SDCL="" ; + ..I SDCLO="" S SDCLO=SDCL + ..I SDDAM'?7N!(SDDAM'>3020831) S SDDAM=SDDAMO ; need to finalize the previously sent + ..; Check status. If it is a termination, continue. + ..Q:$D(^TMP("SDDPT",$J,DFN,SDADT)) ; overridden to be process next time + ..;anothercross reference entry will be created; do not need to quit + ..;Q:$D(^SDWL(409.6,"AC",DFN,SDADT,+$G(CRUNID))) ;see above + ..S SDSTAT="" + ..I SDDAM'=SDDAMO!(SDCL'=SDCLO) D + ...; create CT status; the current SDADT has different creation date + ...S SDSTAT="S15"_U_"F"_U_"CT"_U_U_U_U_U S SDDAM=SDDAMO,SDCL=SDCLO + ..I SDSTAT="" D NOW^%DTC N SDTODAY S SDTODAY=X S SDSTAT=$$STATUS^SDRPA05(DFN,SDADT,SDCL,SDTODAY,0) + ..I $P(SDSTAT,"^")=0 Q + ..N SDCOA,SDMSHA S SDCOA=$P(SDSTAT,U,5) S SDMSHA=$P(SDSTAT,U),SD6A=$P(SDSTAT,U,3),SD8A=$P(SDSTAT,U,4) + ..N SDCLL S SDCLL=$P(SDSTAT,U,6) I SDCLL'="" S SDCL=SDCLL + ..S SDSTTY=$P(SDSTAT,U,2) + ..I SDSTTY="P"&(SDREJ="") Q ;do not send in pending status if not rejected ;esw + ..N SDCE Q:'$$DPT^SDRPA08(DFN,.SDCE) ; Create demographic node of ^TMP file. Quit if this failed. + ..N DIC,DA,X D + ...N SDRET S SDRET=$S(SDSTTY="F":"N",1:"Y") + ...S DIC="^SDWL(409.6,"_CRUNID_",1,",DA(1)=CRUNID,DIC("P")=409.69,DIC(0)="X" + ...K DO S X=DFN D FILE^DICN + ...S DA=+Y,DIE=DIC,DA=+Y,DR="1///"_SDADT_";4///"_SDRET_";5///"_SD6A_";6///"_SDDAM_";8///"_SD8A_";9////"_SDCL D ^DIE + ...Q + ..N DIC,DA D + ...; not rejected can be sent only as 'S'- sent as final + ...N SDRET S SDRET=$S(SDREJ'="":"R",1:"S") ; indicates that it was: R - sent as rejected, S - sent as final + ...S DIC="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID + ...S DA=APPTID,DIE=DIC,DR="4////"_SDRET D ^DIE + ...Q + ..D APPT^SDRPA08(DFN,SDADT,$$DTCONV^SDRPA08(SDDAM),SDCL,SDSTAT) + ..S SDFF=$P(SDSTAT,"^",4) D STAT(SDSTTY,SDFF,.SDFIN,.SDPEN,.SDF) + ..S SDTR=SDTR+1 I SDTR=5000 D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) K ^TMP("SDDPT",$J) S SDTR=0 + ..Q + .Q + Q:SDOUT + I $O(^TMP("SDDPT",$J,"")) D SNDS19^SDRPA07(ZTSK,.SDBCID,.SDMCID) + K ^TMP("SDDPT",$J) + D MSGT^SDRPA03(CRUNID,SDPEN,SDFIN) + Q +STMES ;generate start message + N SDS,SD870,SD87 + S SD870=$O(^HLCS(870,"B","SD-PAIT","")) + N ARRAY D GETS^DIQ(870,SD870_",",4,"I","ARRAY") + N SD87 S SD87=SD870_"," + S SDSTAT=ARRAY(870,SD87,4,"I") + D NOW^%DTC + N SDDT,SDST S SDDT=% + S SDST=$P($$SITE^VASITE(),"^",3) + N SDAMX,XMSUB,CMY,XMTEXT,XMDUZ + S XMSUB=$G(SDST)_" - PAIT START JOB" + S XMY("G.SD-PAIT")="" + S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" + S XMTEXT="SDAMX(" + S XMDUZ="POSTMASTER" + S SDAMX(1)="The PAIT job has started - TASK #: "_ZTSK + S SDAMX(2)="Site Started SD-PAIT status Task #" + S SDAMX(3)=SDST_" |"_SDDT_" |"_SDSTAT_" |"_ZTSK + ; + I SDSTAT="Shutdown" S XMY("VHACIONHD@MED.VA.GOV")="" D + .S SDAMX(4)=" Please start NOIS call for station "_SDST + .S SDAMX(5)="SD-PAIT Logical Link has to be started." + .S SDAMX(6)="" + D ^XMD + Q + ; +GT90DAYS(X1,X2) ; Date is older than Sep 1st 2003, see specs. + ; X1 - creation date. More efficient to have it set at the top instead of every time this subroutine is called. + ; X2 - comparison date, now sent as Sep 1 2003, both in Vista format cyymmdd + D ^%DTC + Q X>0 ; +STAT(SDSTTY,SDFF,SDFIN,SDPEN,SDF) ;summarize pending and finals + I SDSTTY="F" S SDFIN=SDFIN+1 Q + I SDSTTY="P" S SDPEN=SDPEN+1 I SDFF="F" S SDF=SDF+1 + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA04.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA04.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA04.m (revision 623) @@ -1,143 +1,140 @@ -SDRPA04 ;BP-OIFO/ESW - SDRPA00 continuation PAIT - REPAIR ; 11/2/04 11:47am ; 5/31/07 5:29pm - ;;5.3;Scheduling;**376,491**;Aug 13, 1993;Build 53 - ;SD/491 - not to error out while repairing with acks having received - Q -MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP) ;create completion messages - ;CRUNID - current run number - ;SDPEN - pendings - ;SDFIN - finals - ;SDTOT - total - ;SDSTOP - task stop flag - N SDB,SDTRF - I '$D(SDTOT) S SDTOT=SDPEN+SDFIN - N SFF S SFF=0 - I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1 - I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1 - N SDB,SDTRF - S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches - N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2) - N DA,DIE,DR D - .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE - D CLEAN(CRUNID) - N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870 - ;SDS - STATION # - ;SDSTAT - SD-PAIT STATUS - ;SDAIP - IP ADDRESS - ;SDAR - COMMIT ACK RECEIVED - ;SDAP - COMMIT ACK PROCESSED - ;SDMT - MESSAGES (BATCHES) TO SEND - ;SDMS - MESSAGES (BATCHES) SENT - S SD870=$O(^HLCS(870,"B","SD-PAIT","")) - N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY") - N SD87 S SD87=SD870_"," - S SDSTAT=ARRAY(870,SD87,4,"I") - S SDAR=ARRAY(870,SD87,5,"I") - S SDAP=ARRAY(870,SD87,6,"I") - S SDMS=ARRAY(870,SD87,7,"I") - S SDMT=ARRAY(870,SD87,8,"I") - S SDIP=ARRAY(870,SD87,400.01,"I") - S SDS=$P($$SITE^VASITE(),"^",3) - ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3) - N SDBT,STSK,SDSL ; Starting and Last scanned date - S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4) - S STSK=$P(^SDWL(409.6,CRUNID,0),U,2) - S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2) -MSG ;send mail message - N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ - S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB" - S XMY("G.SD-PAIT")="" - S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" - S XMTEXT="SDAMX(" - S DUZ="" - S XMDUZ="POSTMASTER" - S SDAMX(1)="" - S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF - S SDAMX(3)="Started: "_SDBT_" Last Scanned: "_SDSL - S SDAMX(4)="Pending appointments: "_$J(SDPEN,10) - S SDAMX(5)="Final appointments: "_$J(SDFIN,10) - S SDAMX(6)=" ----------" - S SDAMX(7)="Total appointments: "_$J(SDTOT,10)_" Number of batches: "_SDB - S SDAMX(8)="" - S SDAMX(9)="Fac Log Bch Appt # Date finished IP Address Gen Sent Com R Com P Status" - S SDAMX(10)="-----------------------------------------------------------------------" - S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT - S SDAMX(12)="" - I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D D ^XMD Q - .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED." - .S SDAMX(14)="Initiate a Remedy ticket TO FOLLOW UP." - I 'SFF I SDMT>0!(SDB=0) D D ^XMD K ^TMP("SDDPT",$J) Q - .I (SDMT-SDMS)=0 D Q - ..S SDAMX(13)="SUCCESS: Transmission completed." - .I (SDMT-SDMS)0 I (SDMT-SDMS)'0 I (SDMT-SDMS)'1 - W !,"The repairing in progress...",! - N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK - S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE="" - S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q - S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7 - S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry - I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4) - I +SDEB>0 D - .S SDFE=SDRCNT+1 F S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'>SDEB&($P(^SDWL(409.6,RUN,1,SDFE,0),U,3)'="") Q ; SD/491 - .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created - .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7) - .S SDLSD=$P(SDE,U,4) ; last scanned date - .I SDLSD="" D - ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1) - .E S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1 - N SDS,DIK F SDS=SDFE+1:1:SDRCNT I $D(^SDWL(409.6,RUN,1,SDS,0)) D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK - S SDB=+$P($G(^SDWL(409.6,RUN,2,0)),U,3) - S NOW=$$NOW^XLFDT,SDFE=5000*SDB - S $P(^SDWL(409.6,RUN,0),U,5)=SDFE - S $P(^SDWL(409.6,RUN,0),U,6)=SDB - S $P(^SDWL(409.6,RUN,0),U,7)=NOW - D MSGT(RUN,,,SDFE) - W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",! - Q -EVAL(RUN,SDS) ; - ;evaluate if to update any 'S' or 'R' Retention Flags for - ;the previous entry if exists. - N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0) - S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2) - Q:SDDT="" - ;find a prior entry SDRUN - N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN="" - N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,"")) - N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0) - N SDRET S SDRET=$P(SDSTRP,"^",5) - I SDRET="S"!(SDRET="R") N DIC D - .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE - Q +SDRPA04 ;BP-OIFO/ESW - PAIT - REPAIR ; 11/2/04 11:47am + ;;5.3;Scheduling;**376**;Aug 13, 1993 + Q +MSGT(CRUNID,SDPEN,SDFIN,SDTOT,SDSTOP) ;create completion messages + ;CRUNID - current run number + ;SDPEN - pendings + ;SDFIN - finals + ;SDTOT - total + ;SDSTOP - task stop flag + N SDB,SDTRF + I '$D(SDTOT) S SDTOT=SDPEN+SDFIN + N SFF S SFF=0 + I +SDTOT=0 S (SDPEN,SDFIN)=0,SFF=1 + I '$D(SDPEN),'$D(SDFIN) S (SDPEN,SDFIN)="undetermined",SFF=1 + N SDB,SDTRF + S SDB=SDTOT\5000 I SDTOT-(5000*SDB)>0 S SDB=SDB+1 ;# of batches + N NOW S NOW=$$NOW^XLFDT S SDTRF=$$FMTE^XLFDT(NOW,2),SDTRF=$P(SDTRF,":",1,2) + N DA,DIE,DR D + .S DA=CRUNID,DIE=409.6,DR="1.3///"_SDTOT_";1.4///"_SDB_";1.5///"_NOW D ^DIE + D CLEAN(CRUNID) + N SDS,SDSTAT,SDIP,SDAR,SDAP,SDMT,SDMS,SD870 + ;SDS - STATION # + ;SDSTAT - SD-PAIT STATUS + ;SDAIP - IP ADDRESS + ;SDAR - COMMIT ACK RECEIVED + ;SDAP - COMMIT ACK PROCESSED + ;SDMT - MESSAGES (BATCHES) TO SEND + ;SDMS - MESSAGES (BATCHES) SENT + S SD870=$O(^HLCS(870,"B","SD-PAIT","")) + N ARRAY D GETS^DIQ(870,SD870_",","4;5;6;7;8;400.01","I","ARRAY") + N SD87 S SD87=SD870_"," + S SDSTAT=ARRAY(870,SD87,4,"I") + S SDAR=ARRAY(870,SD87,5,"I") + S SDAP=ARRAY(870,SD87,6,"I") + S SDMS=ARRAY(870,SD87,7,"I") + S SDMT=ARRAY(870,SD87,8,"I") + S SDIP=ARRAY(870,SD87,400.01,"I") + S SDS=$P($$SITE^VASITE(),"^",3) + ;S SDS=$E($O(^SDWL(409.6,"AMSG","")),1,3) + N SDBT,STSK,SDSL ; Starting and Last scanned date + S SDBT=$P(^SDWL(409.6,CRUNID,0),U),SDSL=$P(^SDWL(409.6,CRUNID,0),U,4) + S STSK=$P(^SDWL(409.6,CRUNID,0),U,2) + S SDBT=$$FMTE^XLFDT(SDBT,2),SDSL=$$FMTE^XLFDT(SDSL,2) +MSG ;send mail message + N SDAMX,XMSUB,XMY,XMTEXT,XMDUZ + S XMSUB=$G(SDS)_" - PAIT BACKGROUND JOB" + S XMY("G.SD-PAIT")="" + S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" + S XMTEXT="SDAMX(" + S DUZ="" + S XMDUZ="POSTMASTER" + S SDAMX(1)="" + S SDAMX(2)="The PAIT job has completed - TASK #: "_STSK_" Log #: "_CRUNID_" on "_SDTRF + S SDAMX(3)="Started: "_SDBT_" Last Scanned: "_SDSL + S SDAMX(4)="Pending appointments: "_$J(SDPEN,10) + S SDAMX(5)="Final appointments: "_$J(SDFIN,10) + S SDAMX(6)=" ----------" + S SDAMX(7)="Total appointments: "_$J(SDTOT,10)_" Number of batches: "_SDB + S SDAMX(8)="" + S SDAMX(9)="Fac Log Bch Appt # Date finished IP Address Gen Sent Com R Com P Status" + S SDAMX(10)="-----------------------------------------------------------------------" + S SDAMX(11)=SDS_"|"_$J(CRUNID,3)_"|"_$J(SDB,3)_"|"_$J(SDTOT,7)_"|"_SDTRF_"|"_$J(SDIP,11)_"|"_$J(SDMT,4)_"|"_$J(SDMS,4)_"|"_$J(SDAR,4)_"|"_$J(SDAP,4)_"| "_SDSTAT + S SDAMX(12)="" + I $G(SDSTOP) S XMY("VHACIONHD@MED.VA.GOV")="" D D ^XMD Q + .S SDAMX(13)="WARNING: TASK STOPPED BY USER, NEEDS TO BE RESTARTED." + .S SDAMX(14)="INITIATE a NOIS TO FOLLOW UP." + I 'SFF I SDMT>0!(SDB=0) D D ^XMD Q + .I (SDMT-SDMS)=0 D Q + ..S SDAMX(13)="SUCCESS: Transmission completed." + .I (SDMT-SDMS)0 I (SDMT-SDMS)'1 + W !,"The repairing in progress...",! + N SDE,SDEB,SDFE,SDLSD,SDRCNT,ZTSK + S SDE=$G(^SDWL(409.6,RUN,0)) Q:SDE="" + S ZTSK=$P(SDE,"^",2) D STAT^%ZTLOAD I ZTSK(1)=1!(ZTSK(1)=2) W !,"Task "_ZTSK_"is still active!" Q + S SDEB=+$P(SDE,"^",3) ; last batch # submitted to HL7 + S SDRCNT=$O(^SDWL(409.6,RUN,1,999999999),-1) ;last entry + I SDEB=0 S SDFE=0 S $P(^SDWL(409.6,RUN,0),U,4)=$P(^SDWL(409.6,RUN-1,0),U,4) + I +SDEB>0 D + .S SDFE=SDRCNT+1 F S SDFE=$O(^SDWL(409.6,RUN,1,SDFE),-1) I $P(^SDWL(409.6,RUN,1,SDFE,0),U,3)=SDEB Q ; last accepted entry + .N SDLSD1 S SDLSD1=$P(^SDWL(409.6,RUN,1,SDFE,0),U,7) ;retrieve the last used creation date of HL7 created + .N SDLSD2 S SDLSD2=$P($G(^SDWL(409.6,RUN,1,SDFE+1,0)),U,7) + .S SDLSD=$P(SDE,U,4) ; last scanned date + .I SDLSD="" D + ..S $P(^SDWL(409.6,RUN,0),U,4)=$S(SDLSD2>SDLSD1:SDLSD1,1:SDLSD1-1) + .E S $P(^SDWL(409.6,RUN,0),U,4)=SDLSD-1 + N SDS,DIK F SDS=SDFE+1:1:SDRCNT D EVAL(RUN,SDS) S DIK="^SDWL(409.6,"_RUN_",1,",DA(1)=RUN,DA=SDS D ^DIK + S SDB=SDFE\5000 I SDFE-(5000*SDB)>0 S SDB=SDB+1 + S NOW=$$NOW^XLFDT + S $P(^SDWL(409.6,RUN,0),U,5)=SDFE + S $P(^SDWL(409.6,RUN,0),U,6)=SDB + S $P(^SDWL(409.6,RUN,0),U,7)=NOW + D MSGT(RUN,,,SDFE) + W !!,"The last run number has been repaired, you may ONE TIME QUEUE the next one.",! + Q +EVAL(RUN,SDS) ; + ;evaluate if to update any 'S' or 'R' Retention Flags for + ;the previous entry if exists. + N SDSTR,DFN,SDDT S SDSTR=^SDWL(409.6,RUN,1,SDS,0) + S DFN=+SDSTR,SDDT=$P(SDSTR,"^",2) + ;find a prior entry SDRUN + N SDRUN S SDRUN=$O(^SDWL(409.6,"AC",DFN,SDDT,RUN),-1) Q:SDRUN="" + N SDSQ S SDSQ=$O(^SDWL(409.6,"AC",DFN,SDDT,SDRUN,"")) + N SDSTRP S SDSTRP=^SDWL(409.6,SDRUN,1,SDSQ,0) + N SDRET S SDRET=$P(SDSTRP,"^",5) + I SDRET="S"!(SDRET="R") N DIC D + .S SDRET="Y",DIC="^SDWL(409.6,"_SDRUN_",1,",DA(1)=SDRUN,DA=SDSQ,DIE=DIC,DR="4///"_SDRET D ^DIE + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA05.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA05.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA05.m (revision 623) @@ -1,105 +1,104 @@ -SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7 ; 9/10/04 9:34am - ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 2003;Build 53 - ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management - ;SD/491 - MODIFIED $$SCHEDULE to cut off appointments considered as rescheduled by with the scheduled date<2250000 - Q - ; -STATUS(DFN,SDADT,SDCL,TODAY,SFD) ; - ;Input: - ; SDADT - Appt date/time - ; SDCL - Clinic IEN - ; SFD: - 0 - if called from scanning previous runs - update - ; - 1 - if called from scanning 2.98 - ;Output: - ; SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD - ; where: - ; SDMSH -HL7 segment - ; SD25 - Filler Status: - ; P - Pending - ; F - Final - ; SD6 - Event Reason - ; SD8 - Appt Type - ; SD8RD - rescheduled date/time if SD8="RS" - ; SDCO - check out date - ; SDCLL - clinic IEN from matching encounter - ; - N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD - S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I") - I SDST'="" I SDST'="NT"&(SDST'="I") D Q SDSTAT - .S SD25="F",SDCO="",SD8RD="" - .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D ;cancel by clinic - ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) - .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook - .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D ; cancel by patient - ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) - .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook - .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook - .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show - .;evaluate 'non-count' - .I $P($G(^SC(SDCL,0)),U,17)="Y" D - ..I SD8="" S SD8="NC" Q - ..I SD8="RS" S SD8="RSN" - .; - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - ;process all others - S SD0=^DPT(DFN,"S",SDADT,0) - ; check out from OUTPAT ENCOUNTER - ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7) - N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7) - N SDSTATX,SDX3 - S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA) - ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out - I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL - I SDCO'=""&(+SDSTATX'=12) D Q SDSTAT - .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12") - .I +SDSTATX=3 S SD8="AR" ; action required - .I +SDSTATX=8 S SD8="I" ;inpatient - .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out - .I +SDSTATX=2 S SD8="O" ;outpatient - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - I +SDSTATX=3 D Q SDSTAT - .S SD25="P",SDMSH="S12",SDCO="",SD8RD="" - .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required - .E S SD6="",SD8="NAT",SD8RD="" ;no action taken - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D Q SDSTAT - .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient - .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future - .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD - ; - ;process non-count (not checked out) - I +SDSTATX=12 N SDCLL S SDCLL="" D S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT - .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P" - .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q - .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F D Q:'SDSCE!(SD6="COE") - ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK) - ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D - ...N SDCL0,SDCL1,SDCL2 - ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D Q - ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ; - ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18) - ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18) - ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q - ...; proceed if the same DSS IDs pairs - ...S SDCO=$P(SDDATA(0),"^",7) - ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q - ...;encounter exists but not in final (chek out) status - ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 - .I SD6="COE" Q - .;check out by matching encounter - .E I ((TODAY\1)-(SDADT\1))>2 D ;give 2 days to update - ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped - Q 0 - ; -SCHEDULE(DFN,SDCL,SDADT) ; Scheduling flag - ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that - ; appointment is created for a clinic with the same stop code then return "RS". - ; If there is not another appointment made on the same day, return "". - N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date - Q:'SDCDT "" - N SDCDTI S SDCDTI=SDCDT\1 - N SDRESCH S SDRESCH="" - ;exclude the same appointments - N SDAPDT S SDAPDT="" F S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT="" I SDAPDT>3030000 I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D Q:SDRESCH'="" - .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers - S:SDRESCH="" SDRESCH="^" Q SDRESCH +SDRPA05 ;BP-OIFO/ESW - Evaluate appointment status for HL7 ; 9/10/04 9:34am + ;;5.3;Scheduling;**290,333,349,376**;AUG 13, 2003 + ;Evaluation of the appointment status is done from the computed field to match the displayed/printed status in the appointment management + Q + ; +STATUS(DFN,SDADT,SDCL,TODAY,SFD) ; + ;Input: + ; SDADT - Appt date/time + ; SDCL - Clinic IEN + ; SFD: - 0 - if called from scanning previous runs - update + ; - 1 - if called from scanning 2.98 + ;Output: + ; SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL_U_SD8RD + ; where: + ; SDMSH -HL7 segment + ; SD25 - Filler Status: + ; P - Pending + ; F - Final + ; SD6 - Event Reason + ; SD8 - Appt Type + ; SD8RD - rescheduled date/time if SD8="RS" + ; SDCO - check out date + ; SDCLL - clinic IEN from matching encounter + ; + N SD0,SDST,SD6,SD8,SD25,SDMSH,SDCO,SDSTAT,SD8S,SD8RD + S SDST=$$GET1^DIQ(2.98,SDADT_","_DFN_",",3,"I") + I SDST'="" I SDST'="NT"&(SDST'="I") D Q SDSTAT + .S SD25="F",SDCO="",SD8RD="" + .I SDST="C" S SD6="CC",SD8="",SDMSH="S15" D ;cancel by clinic + ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) + .I SDST="CA" S SD6="CC",SD8="ABK",SDMSH="S15" ;cancel bt clinic and auto rebook + .I SDST="PC" S SD6="CP",SD8="",SDMSH="S15" D ; cancel by patient + ..S SD8S=$$SCHEDULE(DFN,SDCL,SDADT),SD8=$P(SD8S,U),SD8RD=$P(SD8S,U,2) + .I SDST="PCA" S SD6="CP",SD8="ABK",SDMSH="S15" ;cancel by patient and auto rebook + .I SDST="NA" S SD6="NS",SD8="ABK",SDMSH="S26" ;no show and auto rebook + .I SDST="N" S SD6="NS",SD8="",SDMSH="S26" ;no show + .;evaluate 'non-count' + .I $P($G(^SC(SDCL,0)),U,17)="Y" D + ..I SD8="" S SD8="NC" Q + ..I SD8="RS" S SD8="RSN" + .; + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + ;process all others + S SD0=^DPT(DFN,"S",SDADT,0) + ; check out from OUTPAT ENCOUNTER + ;N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0 S SDCO=$P(^SCE(SCE,0),"^",7) + N SCE S SCE=$P(SD0,"^",20) S SDCO="" I SCE>0,$D(^SCE(SCE,0)) S SDCO=$P(^SCE(SCE,0),"^",7) + N SDSTATX,SDX3 + S SDSTATX=$$STATUS^SDAM1(DFN,SDADT,SDCL,SD0) ;call to compute the status (VistA) + ;SDSTATX=Appt status IFN in 409.63 ; status name ; print status ; check in ; check out + I SDCO="" S SDCO=$P(SDSTATX,";",5) ; check out from clinic if NULL + I SDCO'=""&(+SDSTATX'=12) D Q SDSTAT + .S SD6="CO",SD25="F",SD8="",SD8RD="",SDMSH=$S(SFD=0:"S14",1:"S12") + .I +SDSTATX=3 S SD8="AR" ; action required + .I +SDSTATX=8 S SD8="I" ;inpatient + .;I +SDSTATX=12 S SD8="NC" ;non-count excluded to be compared to possible encounter does not matter if check out + .I +SDSTATX=2 S SD8="O" ;outpatient + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + I +SDSTATX=3 D Q SDSTAT + .S SD25="P",SDMSH="S12",SDCO="",SD8RD="" + .I $P(SDSTATX,";",4)'="" S SD6="CI",SD8="AR" ;check in/action required + .E S SD6="",SD8="NAT",SD8RD="" ;no action taken + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + I +SDSTATX=8!(+SDSTATX=11) S SD25="P",SD8RD="" D Q SDSTAT + .I +SDSTATX=8 S SD6="",SD8="I",SDCO="",SDMSH="S12" ;inpatient + .I +SDSTATX=11 S SD6="",SD8="F",SDCO="",SDMSH="S12" ;future + .S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_U_SD8RD + ; + ;process non-count (not checked out) + I +SDSTATX=12 N SDCLL S SDCLL="" D S:SD6'="COE" SDCLL=SDCL S SDSTAT=SDMSH_U_SD25_U_SD6_U_SD8_U_SDCO_U_SDCLL Q SDSTAT + .S SD6="",SD8="NC",SDCO="",SDMSH="S12",SD25="P" + .I (SDADT\1)-(TODAY\1)>0 S SD6="",SD8="NCF",SD25="P" Q + .N SDADTC,SDSCE,SDADTCK S SDADTC=(SDADT\1)-1+.99,SDADTCK=SDADTC+1 F D Q:'SDSCE!(SD6="COE") + ..S SDSCE=$$EXAE^SDOE(DFN,SDADTC,SDADTCK) + ..I SDSCE>1 N SDDATA D GETGEN^SDOE(SDSCE,"SDDATA") D + ...N SDCL0,SDCL1,SDCL2 + ...S SDCLL=$P(SDDATA(0),"^",4) I $P(^SC(SDCLL,0),"^",17)="Y" D Q + ....S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 ; + ...S SDCL0=$P(^SC(SDCL,0),"^",7)_$P(^SC(SDCL,0),"^",18) + ...S SDCL2=$P(^SC(SDCLL,0),"^",7)_$P(^SC(SDCLL,0),"^",18) + ...I SDCL0'=SDCL2 S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 Q + ...; proceed if the same DSS IDs pairs + ...S SDCO=$P(SDDATA(0),"^",7) + ...I SDCO'="" S SD6="COE",SD25="F",SDMSH=$S(SFD=0:"S14",1:"S12") Q + ...;encounter exists but not in final (chek out) status + ...S SDADTC=$P(^SCE(SDSCE,0),"^")+.000001 + .I SD6="COE" Q + .;check out by matching encounter + .E I ((TODAY\1)-(SDADT\1))>2 D ;give 2 days to update + ..S SD6="NM",SD25="F",SDMSH=$S(SFD=0:"S14",1:0) ;no match, to be skipped + Q 0 + ; +SCHEDULE(DFN,SDCL,SDADT) ; Scheduling flag + ; If the patient has another appointment created on the same day as the cancellation date of the canceled appt, and that + ; appointment is created for a clinic with the same stop code then return "RS". + ; If there is not another appointment made on the same day, return "". + N SDCDT,SDCLN S SDCDT=$$GET1^DIQ(2.98,SDADT_","_DFN_",",15,"I") ;cancellation date + Q:'SDCDT "" + N SDCDTI S SDCDTI=SDCDT\1 + N SDRESCH S SDRESCH="" + ;exclude the same appointments + N SDAPDT S SDAPDT="" F S SDAPDT=$O(^DPT("ASADM",SDCDTI,DFN,SDAPDT)) Q:SDAPDT="" I SDAPDT'=SDADT I $D(^DPT(DFN,"S",SDAPDT)) D Q:SDRESCH'="" + .S SDCLN=+$P(^DPT(DFN,"S",SDAPDT,0),U) I $P(^SC(SDCLN,0),"^",7)=$P(^SC(SDCL,0),"^",7) S SDRESCH="RS"_"^"_SDAPDT ;compare stop code pointers + S:SDRESCH="" SDRESCH="^" Q SDRESCH Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA06.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA06.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDRPA06.m (revision 623) @@ -1,214 +1,214 @@ -SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm - ;;5.3;Scheduling;**290,333,349,376,491**;AUG 13, 1993;Build 53 - ;routine called from Vista HL7 when ack messages are received in response - ;to an out going HL7 message generated by protocol SC-PAIT-EVENT -ACK ;entry point from Vista HL7 - ;ACKDATE : date/time ack received - ;FLDSEP : field separator - ;CMPNTSEP : component separator - ;REPTNSEP : repetition separator - ;ACKCODE : acknowledgement code - ;ERROR : reject reason - ;BATCHID : batch control ID - ;BATCHIDO : original batch control ID - N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1 - ;disable automatic repair of the last run, not needed to process acks - ;NHD will be notified when the completion message does not come out - ;D RSTAT^SDRPA02 ;check the status of the last run - K ^TMP("SDRPA06",$J) - S SDZAP=0 - S ACKDATE=$$NOW^XLFDT() - S FLDSEP=HL("FS") - S CMPNTSEP=$E(HL("ECH"),1) - S REPTNSEP=$E(HL("ECH"),2) - S ACKCODE=$P(HLMSA,FLDSEP) - S ERROR=$P(HLMSA,FLDSEP,4) - S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2) - S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN - S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id - Q:'BATCHID ;error needs to be handled - ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,"")) - S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1="" - Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO) ;check for duplicate - S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics - I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q ;whole batch rejection - ;Q:($E(ACKCODE,1,2)'="AA") ;quit if not a application ack - ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore - F X HLNEXT Q:(HLQUIT'>0) D ;start looping the msg text - . Q:($E(HLNODE,1,3)'="MSA") ;skip if not a MSA segment - . I $P(HLNODE,FLDSEP,2)="AE" D ;it's an error - .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))="" ;no message number - .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message # - I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q ;whole batch accept - D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors - Q -AR(BATCH,BATCHIDO) ;whole batch rejection - ;BATCH : originating batch number - ;BATCHIDO : original batch number from HL7 ACK - ;V1 : sequence # (individual message number in batch) - ;V2 : run # (ien of multiple entry) - ;V3 : ien (ien in patient multiple) - ;V4 : ien (ien batch tracking multiple) - Q:($G(BATCH)="") - N DA,DIE,DR,V1,V2,V3,V4,ZNODE - S V1=0 - F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D - . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 - . ;batch tracking enhancement - . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D - .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE - .. D ^DIE K DIE - . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D - .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" - .. ;4TH PIECE IS MESSAGE NUMBER - .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," - .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE - .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q - .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D - ... S DR="4///Y" D ^DIE - Q -AA(BATCH,BATCHIDO) ;whole batch accept - ;if the batch is accepted and no rejections then get the run # sequence # - ;from AMSG xref. If no "AE","Y" xref then call DIK to delete the entry - ;BATCH : originating batch number - ;BATCHIDO : original batch number from HL7 ACK - ;V1 : sequence # (individual message number in batch) - ;V2 : run # (ien of multiple entry) - ;V3 : ien (ien in patient multiple) - ;V4 : ien (ien batch tracking multiple) - Q:($G(BATCH)="") - N DA,DIK,DR,V1,V2,V3,V4,ZNODE - S V1=0 - F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D - . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 - . ;batch tracking enhancement - . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D - .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE - .. D ^DIE K DIE - . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D - .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" - .. ;4th piece is the message # - .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D - ... S DIK="^SDWL(409.6,"_V2_",1," - ... S DA(1)=V2,DA=V3 D ^DIK - ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics - Q -AAAR(BATCH,BATCHIDO) ;batch accept with errors - ;BATCH : originating batch number - ;BATCHIDO : original batch number from HL7 ACK - ;V1 : sequence # (individual message number in batch) - ;V2 : run # (ien of multiple entry) - ;V3 : ien (ien in patient multiple) - ;V4 : ien (ien batch tracking multiple)) - Q:($G(BATCH)="") - N DA,DIK,DR,V1,V2,V3,V4,ZNODE - S V1=0 - F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D - . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 - . ;batch tracking enhancement - . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D - .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE - .. D ^DIE K DIE - . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D - .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" - .. ;4th piece is the message # - .. ;next line screens for accepted batch + accepted message + status final and can be deleted - .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D - ... S DIK="^SDWL(409.6,"_V2_",1," - ... S DA(1)=V2,DA=V3 D ^DIK - ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics - .. ;next line screens for accepted batch + error message - .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D - ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," - ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE - ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q - ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D - .... S DR="4///Y" D ^DIE - Q -CLEAN(RUN) ;housekeeping - ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and - ;deleting if entry in xref exists - ;RUN : run # (ien of multiple entry) - ;V1 : previous run # (ien of multiple entry) - ;V2 : ien (ien in multiple) - Q:($G(RUN)="") - N V1,V2,V3 - S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1 - F V3="R","S" S V2=0 F S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2 D - . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0)) - . S DIK="^SDWL(409.6,"_V1_",1," - . S DA(1)=V1,DA=V2 D ^DIK - . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics - Q -MSG(BATCHIDO,TYPE,RUNIEN,BATCHID) ;acknowledgement notification to mail group - ;BATCHID : Our Message ID - ;BATCHIDO: Batch Control ID - ;TYPE : type of message (accept with rejects - 1, whole accept 2, whole reject -3) - ;RUNIEN : run ien associated with this batch - ;SDAMX : message text array - ;XMSUB : subject - ;XMY : addressee - ;XMTEXT : location of text array - ;XMDUZ : sender of the message - ;RUNZ : zero node of run associated with this batch - N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ - Q:BATCHID="" - L +^SDWL(409.6,RUNIEN,2,0) - S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4) - S (V1,V3)=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1 D - . S:$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4)'="" V3=V3+1 - L -^SDWL(409.6,RUNIEN,2,0) - S RUNZ=$G(^SDWL(409.6,RUNIEN,0)) - S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO - S XMY("G.SD-PAIT")="" - S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" - S XMTEXT="SDAMX(" - S XMDUZ="POSTMASTER" - I TYPE=1 D - . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) - . S SDAMX(2)="Batch Control ID: "_BATCHIDO - . S SDAMX(3)=" Message ID: "_BATCHID - . S SDAMX(4)=" Log Entry: "_RUNIEN - . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) - . S SDAMX(6)=" Status: Acknowledged - with rejections " - . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" - . S SDAMX(8)="" - . S SDAMX(9)="Use option SD-PAIT REJECTED Rejected Transmissions to view the rejections." - I TYPE=2 D - . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) - . S SDAMX(2)="Batch Control ID: "_BATCHIDO - . S SDAMX(3)=" Message ID: "_BATCHID - . S SDAMX(4)=" Log Entry: "_RUNIEN - . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) - . S SDAMX(6)=" Status: Acknowledged - No Rejections" - . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" - I TYPE=3 D - . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) - . S SDAMX(2)="Batch Control ID: "_BATCHIDO - . S SDAMX(3)=" Message ID: "_BATCHID - . S SDAMX(4)=" Log Entry: "_RUNIEN - . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) - . S SDAMX(6)=" Status: Acknowledged - Entire Batch Rejected" - . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" - D ^XMD - Q -OURB(RUNIEN,BATCHIDO) ;match batch id to msg control id ("AMSG" xref) - ;RUNIEN : the ien in file 409.6 of the run - ;BATCHIDO : batchid pulled from the ACK message - ;V2 : returns 0 if none, or msg control id - N V1,V2,VNODE - S V2=0 - I '$G(RUNIEN) Q V2 - I '$G(BATCHIDO) Q V2 - I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2 - S V1=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1 D - . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE="" - . I $P(VNODE,"^",3)="" Q - . S V2=$P(VNODE,"^",3) Q - Q V2 -RUNIEN(BATCHID) ;get runien - N V1,V2 - S V2=0 - S V1=999999999 F S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2) D - . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q - Q V2 +SDRPA06 ;bp-oifo/swo pait hl7 ack handling ; 10/31/04 3:53pm + ;;5.3;Scheduling;**290,333,349,376**;AUG 13, 1993 + ;routine called from Vista HL7 when ack messages are received in response + ;to an out going HL7 message generated by protocol SC-PAIT-EVENT +ACK ;entry point from Vista HL7 + ;ACKDATE : date/time ack received + ;FLDSEP : field separator + ;CMPNTSEP : component separator + ;REPTNSEP : repetition separator + ;ACKCODE : acknowledgement code + ;ERROR : reject reason + ;BATCHID : batch control ID + ;BATCHIDO : original batch control ID + N ACKCODE,ACKDATE,BATCHID,BATCHIDO,CMPNTSEP,ERROR,FLDSEP,REPTNSEP,RUNIEN,SDZAP,V1 + ;disable automatic repair of the last run, not needed to process acks + ;NHD will be notified when the completion message does not come out + ;D RSTAT^SDRPA02 ;check the status of the last run + K ^TMP("SDRPA06",$J) + S SDZAP=0 + S ACKDATE=$$NOW^XLFDT() + S FLDSEP=HL("FS") + S CMPNTSEP=$E(HL("ECH"),1) + S REPTNSEP=$E(HL("ECH"),2) + S ACKCODE=$P(HLMSA,FLDSEP) + S ERROR=$P(HLMSA,FLDSEP,4) + S (BATCHID,BATCHIDO)=$P(HLMSA,FLDSEP,2) + S RUNIEN=$$RUNIEN(BATCHIDO) Q:'RUNIEN + S BATCHID=$$OURB(RUNIEN,BATCHIDO) ;convert to our batch id + Q:'BATCHID ;error needs to be handled + ;S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")),RUNIEN=$O(^SDWL(409.6,"AMSG",BATCHID,V1,"")) + S V1=$O(^SDWL(409.6,"AMSG",BATCHID,"")) Q:V1="" + Q:'$$DUP^SDRPA02(RUNIEN,BATCHIDO) ;check for duplicate + S ^XTMP("SDRPA-"_BATCHID,0)=$$FMADD^XLFDT($$DT^XLFDT(),3)_"^"_$$DT^XLFDT() ;set xtmp global for diagnostics + I $E(ACKCODE,1,2)="AR" D AR(BATCHID,BATCHIDO),MSG(BATCHIDO,3,RUNIEN,BATCHID) Q ;whole batch rejection + ;Q:($E(ACKCODE,1,2)'="AA") ;quit if not a application ack + ;will only be 2 ACKCODEs AA and AE so don't have to screen anymore + F X HLNEXT Q:(HLQUIT'>0) D ;start looping the msg text + . Q:($E(HLNODE,1,3)'="MSA") ;skip if not a MSA segment + . I $P(HLNODE,FLDSEP,2)="AE" D ;it's an error + .. Q:($P($P(HLNODE,FLDSEP,3),"-",2))="" ;no message number + .. S ^TMP("SDRPA06",$J,+$P($P(HLNODE,FLDSEP,3),"-",2))=+$P(HLNODE,"^",4) ;set xref with message # + I '$D(^TMP("SDRPA06",$J)) D AA(BATCHID,BATCHIDO),MSG(BATCHIDO,2,RUNIEN,BATCHID) Q ;whole batch accept + D AAAR(BATCHID,BATCHIDO),MSG(BATCHIDO,1,RUNIEN,BATCHID) ;batch accept with errors + Q +AR(BATCH,BATCHIDO) ;whole batch rejection + ;BATCH : originating batch number + ;BATCHIDO : original batch number from HL7 ACK + ;V1 : sequence # (individual message number in batch) + ;V2 : run # (ien of multiple entry) + ;V3 : ien (ien in patient multiple) + ;V4 : ien (ien batch tracking multiple) + Q:($G(BATCH)="") + N DA,DIE,DR,V1,V2,V3,V4,ZNODE + S V1=0 + F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D + . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 + . ;batch tracking enhancement + . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D + .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE + .. D ^DIE K DIE + . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D + .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" + .. ;4TH PIECE IS MESSAGE NUMBER + .. S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," + .. S DR="7////"_$O(^SCPT(404.472,"B","R","")) D ^DIE + .. I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q + .. I $D(^SDWL(409.6,"AE","N",V2,V3)) D + ... S DR="4///Y" D ^DIE + Q +AA(BATCH,BATCHIDO) ;whole batch accept + ;if the batch is accepted and no rejections then get the run # sequence # + ;from AMSG xref. If no "AE","Y" xref then call DIK to delete the entry + ;BATCH : originating batch number + ;BATCHIDO : original batch number from HL7 ACK + ;V1 : sequence # (individual message number in batch) + ;V2 : run # (ien of multiple entry) + ;V3 : ien (ien in patient multiple) + ;V4 : ien (ien batch tracking multiple) + Q:($G(BATCH)="") + N DA,DIK,DR,V1,V2,V3,V4,ZNODE + S V1=0 + F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D + . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 + . ;batch tracking enhancement + . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D + .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE + .. D ^DIE K DIE + . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D + .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" + .. ;4th piece is the message # + .. I '$D(^SDWL(409.6,"AE","Y",V2,V3)) D + ... S DIK="^SDWL(409.6,"_V2_",1," + ... S DA(1)=V2,DA=V3 D ^DIK + ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics + Q +AAAR(BATCH,BATCHIDO) ;batch accept with errors + ;BATCH : originating batch number + ;BATCHIDO : original batch number from HL7 ACK + ;V1 : sequence # (individual message number in batch) + ;V2 : run # (ien of multiple entry) + ;V3 : ien (ien in patient multiple) + ;V4 : ien (ien batch tracking multiple)) + Q:($G(BATCH)="") + N DA,DIK,DR,V1,V2,V3,V4,ZNODE + S V1=0 + F S V1=$O(^SDWL(409.6,"AMSG",BATCH,V1)) Q:'V1 D + . S V2=$O(^SDWL(409.6,"AMSG",BATCH,V1,"")) Q:'V2 + . ;batch tracking enhancement + . S V4=$O(^SDWL(409.6,V2,2,"B",BATCHIDO,"")) Q:'V4 D + .. S DA=V4,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",2,",DR=".04///"_$$NOW^XLFDT_";.05///"_ACKCODE + .. D ^DIE K DIE + . S V3=0 F S V3=$O(^SDWL(409.6,"AMSG",BATCH,V1,V2,V3)) Q:'V3 D + .. S ZNODE=$G(^SDWL(409.6,V2,1,V3,0)) Q:ZNODE="" + .. ;4th piece is the message # + .. ;next line screens for accepted batch + accepted message + status final and can be deleted + .. I '$D(^SDWL(409.6,"AE","Y",V2,V3))&('$D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4)))) D + ... S DIK="^SDWL(409.6,"_V2_",1," + ... S DA(1)=V2,DA=V3 D ^DIK + ... S ^XTMP("SDRPA-"_BATCH,+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics + .. ;next line screens for accepted batch + error message + .. I $D(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))) D + ... S DA=V3,DA(1)=V2,DIE="^SDWL(409.6,"_V2_",1," + ... S DR="7////"_$O(^SCPT(404.472,"B",$G(^TMP("SDRPA06",$J,$P(ZNODE,"^",4))),"")) D ^DIE + ... I $D(^SDWL(409.6,"AE","Y",V2,V3)) Q + ... I $D(^SDWL(409.6,"AE","N",V2,V3)) D + .... S DR="4///Y" D ^DIE + Q +CLEAN(RUN) ;housekeeping + ;clean up batch previous to current one by checking for "AE",("S" or "R") xref and + ;deleting if entry in xref exists + ;RUN : run # (ien of multiple entry) + ;V1 : previous run # (ien of multiple entry) + ;V2 : ien (ien in multiple) + Q:($G(RUN)="") + N V1,V2,V3 + S V1=$O(^SDWL(409.6,RUN),-1) Q:'V1 + F V3="R","S" S V2=0 F S V2=$O(^SDWL(409.6,"AE",V3,V1,V2)) Q:'V2 D + . S ZNODE=$G(^SDWL(409.6,V1,1,V2,0)) + . S DIK="^SDWL(409.6,"_V1_",1," + . S DA(1)=V1,DA=V2 D ^DIK + . S ^XTMP("SDRPA-"_$P(ZNODE,"^",3),"CLEAN",+$P(ZNODE,"^",4),0)=ZNODE ;diagnostics + Q +MSG(BATCHIDO,TYPE,RUNIEN,BATCHID) ;acknowledgement notification to mail group + ;BATCHID : Our Message ID + ;BATCHIDO: Batch Control ID + ;TYPE : type of message (accept with rejects - 1, whole accept 2, whole reject -3) + ;RUNIEN : run ien associated with this batch + ;SDAMX : message text array + ;XMSUB : subject + ;XMY : addressee + ;XMTEXT : location of text array + ;XMDUZ : sender of the message + ;RUNZ : zero node of run associated with this batch + N RUNZ,SDAMX,V0,V1,V2,V3,XMSUB,XMY,XMTEXT,XMDUZ + Q:BATCHID="" + S V0=$P($G(^SDWL(409.6,RUNIEN,2,0)),"^",4) + S (V1,V3)=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,V1)) Q:'V1 D + . S V2=$P($G(^SDWL(409.6,RUNIEN,2,V1,0)),"^",4) + . S:V2'="" V3=V3+1 + . ;S V3=V3+1 + S RUNZ=$G(^SDWL(409.6,RUNIEN,0)) + S XMSUB="PAIT BATCH ACKNOWLEGEMENT "_BATCHIDO + S XMY("G.SD-PAIT")="" + S XMY("S.SD-PAIT-SERVER@FORUM.VA.GOV")="" + S XMTEXT="SDAMX(" + S XMDUZ="POSTMASTER" + I TYPE=1 D + . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) + . S SDAMX(2)="Batch Control ID: "_BATCHIDO + . S SDAMX(3)=" Message ID: "_BATCHID + . S SDAMX(4)=" Log Entry: "_RUNIEN + . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) + . S SDAMX(6)=" Status: Acknowledged - with rejections " + . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" + . S SDAMX(8)="" + . S SDAMX(9)="Use option SD-PAIT REJECTED Rejected Transmissions to view the rejections." + I TYPE=2 D + . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) + . S SDAMX(2)="Batch Control ID: "_BATCHIDO + . S SDAMX(3)=" Message ID: "_BATCHID + . S SDAMX(4)=" Log Entry: "_RUNIEN + . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) + . S SDAMX(6)=" Status: Acknowledged - No Rejections" + . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" + I TYPE=3 D + . S SDAMX(1)=" Station Number: "_$P($$SITE^VASITE(),"^",3) + . S SDAMX(2)="Batch Control ID: "_BATCHIDO + . S SDAMX(3)=" Message ID: "_BATCHID + . S SDAMX(4)=" Log Entry: "_RUNIEN + . S SDAMX(5)=" Run Date: "_$$FMTE^XLFDT($P(RUNZ,"^",7)) + . S SDAMX(6)=" Status: Acknowledged - Entire Batch Rejected" + . S SDAMX(7)=" "_V3_" of "_V0_" ACKs received for this run date" + D ^XMD + Q +OURB(RUNIEN,BATCHIDO) ;match batch id to msg control id ("AMSG" xref) + ;RUNIEN : the ien in file 409.6 of the run + ;BATCHIDO : batchid pulled from the ACK message + ;V2 : returns 0 if none, or msg control id + N V1,V2,VNODE + S V2=0 + I '$G(RUNIEN) Q V2 + I '$G(BATCHIDO) Q V2 + I $G(^SDWL(409.6,RUNIEN,2,0))="" Q V2 + S V1=0 F S V1=$O(^SDWL(409.6,RUNIEN,2,"B",BATCHIDO,V1)) Q:'V1 D + . S VNODE=$G(^SDWL(409.6,RUNIEN,2,V1,0)) Q:VNODE="" + . I $P(VNODE,"^",3)="" Q + . S V2=$P(VNODE,"^",3) Q + Q V2 +RUNIEN(BATCHID) ;get runien + N V1,V2 + S V2=0 + S V1=999999999 F S V1=$O(^SDWL(409.6,V1),-1) Q:'V1!(V2) D + . I $O(^SDWL(409.6,V1,2,"B",BATCHID,"")) S V2=V1 Q + Q V2 Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU3.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU3.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU3.m (revision 623) @@ -1,65 +1,70 @@ -SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03 - ;;5.3;scheduling;**280,491**;AUG 13 1993;Build 53 - ; - ;modify update of 409.32 and related 409.3 with a proper institution set up in file 44 - ;through the division path - ; -3 ;service specialty edit - S SDWLSS="",SDWLINS="",SDWLERR="" - F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 - .F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1 - ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS - ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01) - ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1) - ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME - ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL - S WLTC3="" - Q -SEL ;select new Insitition - N DIR - S DIR("A")="Select Institution: " - S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR - I X["^" S SDWLERR=1 Q - I Y<1 W *7,"Invalid Entry" G SEL - S SDWLINSN=+Y - D C3,C31 K DIC,D0,D1 - Q -C3 ; - ;check entry to see if it already exist - S DA=SDWLSSX,DA(1)=SDWLSS - I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D - . W !,"Institution already exists for this Specialty...deleting." - . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK - E D - . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE - K DA,DA(1),DR,DIE,DIK - Q -C31 ;update SD WAIT LIST PATIENT file 409.3 - S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D - .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE - .K DR,DIE,DA - .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA) - Q -4 ;specific clinic edit - N SDWLERR,SDWLSC,SDWLINS S SDWLSC="",SDWLINS="",SDWLERR="" - F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D - .F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D UPDINS^SDWLCU5(SDWLSC,.SDWLERR) - Q:SDWLERR - S WLTC4="" - K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK - Q -C41 ;update wait list file - S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D - .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") - .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN - Q -SEL1 ;select valid institution - N DIR - W !!,"Invalid Institution. Please select a National Institution.",! - W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01) - S DIR("A")="Select Institution: " - S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR - I X["^" S SDWLERR=1 Q - I Y<1 W *7,"Invalid Entry" G SEL1 - S SDWLINSN=+Y - Q +SDWLCU3 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP ;2/4/03 + ;;5.3;scheduling;**280**;AUG 13 1993 + ; + ; + ; +3 ;service specialty edit + S SDWLSS="",SDWLINS="",SDWLERR="" + F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 + .F S SDWLSS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSS)) Q:SDWLSS="" D Q:SDWLERR=1 + ..I '$D(SDWLSSV) S SDWLSSV=SDWLSS + ..S NAME=$$GET1^DIQ(4,SDWLINS_",",.01) + ..S SDWLSSN=$P(^SDWL(409.31,SDWLSS,0),U,1) + ..W !,"SERVICE SPECIALTY: ",$$GET1^DIQ(40.7,SDWLSSN_",",.01)," INSTITUTION: ",NAME + ..S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,0)) D:SDWLSSX'="" SEL + S WLTC3="" + Q +SEL ;select new Insitition + N DIR + S DIR("A")="Select Institution: " + S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR + I X["^" S SDWLERR=1 Q + I Y<1 W *7,"Invalid Entry" G SEL + S SDWLINSN=+Y + D C3,C31 K DIC,D0,D1 + Q +C3 ; + ;check entry to see if it already exist + S DA=SDWLSSX,DA(1)=SDWLSS + I $O(^SDWL(409.31,SDWLSS,"I","B",SDWLINSN,0)) D + . W !,"Institution already exists for this Specialty...deleting." + . S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK + E D + . W ! S DR=".01////^S X=SDWLINSN",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE + K DA,DA(1),DR,DIE,DIK + Q +C31 ;update SD WAIT LIST PATIENT file 409.3 + S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA)) Q:SDWLDA="" D + .S DR="2////^S X=SDWLINSN",DIE="^SDWL(409.3,",DA=SDWLDA D ^DIE + .K DR,DIE,DA + .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSSV,SDWLDA),^TMP($J,"EWL",$J,SDWLDA) + Q +4 ;specific clinic edit + S SDWLSC="",SDWLINS="",SDWLERR="" + F S SDWLINS=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS)) Q:SDWLINS="" D Q:SDWLERR=1 + .F S SDWLSC=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC)) Q:SDWLSC="" D Q:SDWLERR=1 + ..S SDWLSCX=$P(^SDWL(409.32,SDWLSC,0),U,1) + ..S SDWLINSN=$P($G(^SC(SDWLSCX,0)),U,4),X=$$GET1^DIQ(4,SDWLINSN_",",11) I X'["N"!('$$TF^XUAF4(SDWLINSN)) D SEL1 + ..;Check 409.32 + ..I $P(^SDWL(409.32,SDWLSC,0),U,6)'=SDWLINSN D + ...K ^SDWL(409.32,"C",SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)="" + ...S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN + ..D C41 + S WLTC4="" + K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK + Q +C41 ;update wait list file + S SDWLDA="" F S SDWLDA=$O(^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA)) Q:SDWLDA="" D + .S SDWLIN(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") + .K ^TMP($J,"SDWLCU1",SDWLTY,SDWLINS,SDWLSC,SDWLDA),^TMP($J,"EWL",$J,SDWLDA),SDWLIN + Q +SEL1 ;select valid institution + N DIR + W !!,"Invalid Institution. Please select a National Institution.",! + W "CLINIC: ",CLNAM," INSTITUTION:",$$GET1^DIQ(4,SDWLINS_",",.01) + S DIR("A")="Select Institution: " + S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR + I X["^" S SDWLERR=1 Q + I Y<1 W *7,"Invalid Entry" G SEL1 + S SDWLINSN=+Y + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU5.m (revision 623) @@ -1,140 +1,114 @@ -SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 ; Compiled August 20, 2007 17:04:58 - ;;5.3;scheduling;**280,427,491**;AUG 13 1993;Build 53 -EN ; - W !!,"Checking file 404.51 one last time.",! - S SDWLERR="",TEAM=0 F S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM D Q:SDWLERR=1 - . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I") - . S CODE=$$GET1^DIQ(4,INST_",",11,"I") - . S INCK=$$TF^XUAF4(INST) - . I CODE'="N"!('INCK) D - .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: " - .. W $$GET1^DIQ(4,INST_",",.01) - .. D EDIT^SDWLCU2 - Q:SDWLERR=1 - ; - W !!,"Checking file 409.31 one last time.",! -40931 S SDWLSS=0 F S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS D Q:SDWLERR=1 - . S SDWLINS="" F S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS D Q:SDWLERR=1 - .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") - .. S INCK=$$TF^XUAF4(SDWLINS) - .. I CODE'="N"!('INCK) D - ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: " - ... W $$GET1^DIQ(4,SDWLINS_",",.01) - ... D GETINS Q:SDWLERR=1 - ... S SDWLSSX="" F S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX D Q:SDWLERR=1 - .... D C3^SDWLCU3 - Q:SDWLERR=1 -40932 W !!,"Checking file 409.32 one last time.",! - N INERROR S INERROR="" S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D UPDINS(SDWLSC,.INERROR) - Q:INERROR=1 - N DIK S DIK="^SDWL(409.32," D IXALL^DIK - W !!,"Checking file 409.3 one last time.",! - S SDWLERR="" - S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1 - .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5) - .Q:'SDWLTY!'SDWLINST - .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI - .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG - W !,"Done." - Q -UPDINS(SDWLSC,INERROR) ; update 409.32 and the related entroes in 409.3 - N SDWLINS S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") ; current set up IN 409.32 - ;check set up in file 44 - ;get clinic - N CL,CLN S CL=$$GET1^DIQ(409.32,SDWLSC_",",.01,"I"),CLN=$$GET1^DIQ(44,CL_",",.01) - N STR,SDWMES S SDWMES="",STR=$$CLIN^SDWLPE(CL) - S SDWMES=SDWMES_$P(STR,U,6) - I $P(STR,U,5)="L" S SDWMES=SDWMES_" - Local Institution assigned to clinic. " - I SDWMES'="" D Q - .W !!," ** Incorrect Setting up of Clinic "_CLN_" ("_CL_")"_": **" - .W !!,SDWMES - .W !!,"INSTALLATION WILL CONTINUE WITHOUT UPDATING THIS ENTRY." - .W !!,"AFTER INSTALLATION CORRECT THE CLINIC SETUP AND THEN",!," RUN OPTION SD WAIT LIST CLEANUP." - .S:INERROR="" INERROR=1 Q - I +STR'=SDWLINS W !!,"Clinic "_CLN_" ("_CL_")"_"does not have the same Institution as EWL set up." D - .W !!,"EWL Clinic INSTITUTION: ",$$GET1^DIQ(4,SDWLINS_",",.01)_" - "_$$GET1^DIQ(4,SDWLINS_",",99) - .W !,"Clinic INSTITUTION: ",$P(STR,U,3)_" - "_$P(STR,U,2) - .W !!,"EWL set up will be updated with the Clinic from the Hospital Location file," - .W !,"and the related open EWL entries will be updated as well." - .N DIE,DR,DA S DR=".02////^S X=+STR",DIE="^SDWL(409.32,",DA=SDWLSC - .L +^SDWL(409.32,DA):0 I '$T W !?5,"Another user is editing this entry. try later." Q - .D ^DIE L -^SDWL(409.32,DA) - .;loop to update EWL entries in FILE 409.3 if any - .N SCL,DA,DR,CNT S SCL="",CNT=0 F S SCL=$O(^SDWL(409.3,"SC",CL,SCL)) Q:SCL'>0 D - ..I '$D(^SDWL(409.3,SCL,0)) K ^SDWL(409.3,"SC",CL,SCL) Q - ..S DR="2////^S X=+STR",DIE="^SDWL(409.3,",DA=SCL - ..L +^SDWL(409.3,SCL):0 I '$T W !?5,"Another user is editing this entry. try later." Q - ..D ^DIE L -^SDWL(409.3,SCL) S CNT=CNT+1 - .I CNT>0 W !,CNT_" EWL entries for clinic "_CLN_" updated." - N DA I $$GET1^DIQ(409.32,SDWLSC_",",3,"I")="" I $$GET1^DIQ(409.32,SDWLSC_",",1,"I")'>0 D - .S DA=SDWLSC L +^SDWL(409.32,SDWLSC):0 I '$T W !?5,"Another user is editing this entry. try later." Q - .S DR="1////^S X=DT;2////^S X=DUZ",DIE="^SDWL(409.32," ;enter activation date and user - .D ^DIE L -^SDWL(409.32,SDWLSC) - .W !,"EWL Clinic entry for "_CLN_" updated with today's activation date." - Q -CHK1 ;CHECK FOR INSTITUTION VALIDILITY - S SDWLERR=0 - I SDWLTY=1 S SDWLI=0 F S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI="" I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)="" - I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q - K ^TMP($J,"SDWLCU5",$J,"B") - I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q - I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q - W !,"Please select a valid Institution for this record from the following list for",! - D DIS - S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D - .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C -CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR - I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q - S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) -CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - S TAG="CHK" - Q -CHK3 ; - S SDWLERR="" - S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8) - Q:'SDWLI!'$D(^SDWL(409.31,SDWLI)) - I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1 - .S SDWLIX="",C=0 F S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX="" S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)="" - .I 'C N SITE S SITE=+$$SITE^VASITE(,) S SDWLINSN=$S(SITE>0:SITE,1:""),Y=1 D CHE3 Q - .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q - .W !,"Please select a valid Institution for this record from the following list for",! - .D DIS - .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D - ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ)) - ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01) - .W ! S DIR(0)="NO^1:"_C D ^DIR - .I $D(DUOUT)!(Y="") S SDWLERR=1 Q - .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) - .D CHE3 - Q -CHE3 ; - G CHK3:Y<0 - S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - S TAG="CHK" - Q -CHK4 ; - S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9) - Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0)) - I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D - .D DIS - .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - Q -CHK2 ; - S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7) - I SDWLINST'=SDWLINSN D - .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") - S TAG="CHK" - Q -DIS ;display record - S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E") - S SSN=$$GET1^DIQ(2,NN_",",.09) - W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!! - Q -GETINS ;Get institution - N DIR - S DIR("A")="Select Institution: " - S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR - I X["^" S SDWLERR=1 Q - I Y<1 W *7,"Invalid Entry" G GETINS - S SDWLINSN=+Y - Q +SDWLCU5 ;IOFO BAY PINES/TEH - EWL FILE 409.3 CLEANUP ;2/4/03 + ;;5.3;scheduling;**280,427**;AUG 13 1993 +EN ; + W !!,"Checking file 404.51 one last time.",! + S SDWLERR="",TEAM=0 F S TEAM=$O(^SCTM(404.51,TEAM)) Q:'TEAM D Q:SDWLERR=1 + . S INST=$$GET1^DIQ(404.51,TEAM_",",.07,"I") + . S CODE=$$GET1^DIQ(4,INST_",",11,"I") + . S INCK=$$TF^XUAF4(INST) + . I CODE'="N"!('INCK) D + .. W !!,"TEAM: ",$$GET1^DIQ(404.51,TEAM_",",.01)," INSTITUTION: " + .. W $$GET1^DIQ(4,INST_",",.01) + .. D EDIT^SDWLCU2 + Q:SDWLERR=1 + ; + W !!,"Checking file 409.31 one last time.",! +40931 S SDWLSS=0 F S SDWLSS=$O(^SDWL(409.31,SDWLSS)) Q:'SDWLSS D Q:SDWLERR=1 + . S SDWLINS="" F S SDWLINS=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS)) Q:'SDWLINS D Q:SDWLERR=1 + .. S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") + .. S INCK=$$TF^XUAF4(SDWLINS) + .. I CODE'="N"!('INCK) D + ... W !!,"SERVICE SPECIALTY: ",$$GET1^DIQ(409.31,SDWLSS_",",.01)," INSTITUTION: " + ... W $$GET1^DIQ(4,SDWLINS_",",.01) + ... D GETINS Q:SDWLERR=1 + ... S SDWLSSX="" F S SDWLSSX=$O(^SDWL(409.31,SDWLSS,"I","B",SDWLINS,SDWLSSX)) Q:'SDWLSSX D Q:SDWLERR=1 + .... D C3^SDWLCU3 + Q:SDWLERR=1 +40932 W !!,"Checking file 409.32 one last time.",! + S SDWLSC=0 F S SDWLSC=$O(^SDWL(409.32,SDWLSC)) Q:'SDWLSC D Q:SDWLERR=1 + . S SDWLINS=$$GET1^DIQ(409.32,SDWLSC_",",.02,"I") + . S CODE=$$GET1^DIQ(4,SDWLINS_",",11,"I") + . S INCK=$$TF^XUAF4(SDWLINS) + . I CODE'="N"!('INCK) D + .. W !!,"CLINIC: ",$$GET1^DIQ(409.32,SDWLSC_",",.01)," INSTITUTION: " + .. W $$GET1^DIQ(4,SDWLINS_",",.01) + .. D GETINS Q:SDWLERR=1 + .. K ^SDWL(409.32,"C",+SDWLINS) S $P(^SDWL(409.32,SDWLSC,0),U,6)=SDWLINSN,^SDWL(409.32,"C",SDWLINSN,SDWLSC)="" + .. S SDWLIN(44,+$P(^SDWL(409.32,SDWLSC,0),"^")_",",3)=SDWLINSN D UPDATE^DIE("","SDWLIN","SDWLMSG") K SDWLIN + K ^SDWL(409.32,"ACT") S DIK="^SDWL(409.32," D IXALL^DIK + Q:SDWLERR=1 + W !!,"Checking file 409.3 one last time.",! + S SDWLERR="" + S SDWLDA=0,TAG="CHK" F S SDWLDA=$O(^SDWL(409.3,SDWLDA)) Q:SDWLDA<1 D Q:SDWLERR=1 + .S X=$G(^SDWL(409.3,SDWLDA,0)),SDWLINST=$P(X,"^",3),SDWLTY=$P(X,"^",5) + .Q:'SDWLTY!'SDWLINST + .S SDWLI=$P(X,"^",SDWLTY+5) Q:'SDWLI + .S TAG="CHK",TAG=TAG_SDWLTY,C=0 K ^TMP($J,"SDWLCU5",$J) D @TAG + W !,"Done." + Q +CHK1 ;CHECK FOR INSTITUTION VALIDILITY + S SDWLERR=0 + I SDWLTY=1 S SDWLI=0 F S SDWLI=$O(^SCTM(404.51,"AINST",SDWLI)) Q:SDWLI="" I $D(^DIC(4,SDWLI)) S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLI)="",^TMP($J,"SDWLCU5",$J,"B",SDWLI)="" + I $D(^TMP($J,"SDWLCU5",$J,"B",SDWLINST)) Q + K ^TMP($J,"SDWLCU5",$J,"B") + I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:"") D CH1E Q + I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)) D CH1E Q + W !,"Please select a valid Institution for this record from the following list for",! + D DIS + S C=0,SDWLI="" F S C=$O(^TMP($J,"SDWLCU5",$J,C)) Q:C<1 D + .F S SDWLI=$O(^TMP($J,"SDWLCU5",$J,C,SDWLI)) Q:SDWLI="" W !,?20,C,". ",$$GET1^DIQ(4,SDWLI_",",.01) S CS=C +CHK10 W ! S DIR(0)="NO^1:"_CS D ^DIR + I Y<1!($D(DUOUT)) W !,"Response Required." S SDWLERR=1 Q + S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) +CH1E S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + S TAG="CHK" + Q +CHK3 ; + S SDWLERR="" + S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,8) + Q:'SDWLI!'$D(^SDWL(409.31,SDWLI)) + I '$D(^SDWL(409.31,SDWLI,"I","B",SDWLINST)) D Q:SDWLERR=1 + .S SDWLIX="",C=0 F S SDWLIX=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIX)) Q:SDWLIX="" S C=C+1,^TMP($J,"SDWLCU5",$J,C,SDWLIX)="",^TMP($J,"SDWLCU5",$J,"B",SDWLIX)="" + .I 'C S SDWLINSN=$S($D(DUZ(2)):DUZ(2),1:""),Y=1 D CHE3 Q + .I C=1 S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,C,0)),Y=1 D CHE3 Q + .W !,"Please select a valid Institution for this record from the following list for",! + .D DIS + .S C=0,SDWLIZ=0 F S SDWLIZ=$O(^SDWL(409.31,SDWLI,"I","B",SDWLIZ)) Q:SDWLIZ="" D + ..Q:$$GET1^DIQ(4,SDWLIZ_",",11,"I")'="N"!('$$TF^XUAF4(SDWLIZ)) + ..S C=C+1 W !,?20,C,". ",$$GET1^DIQ(4,SDWLIZ_",",.01) + .W ! S DIR(0)="NO^1:"_C D ^DIR + .I $D(DUOUT)!(Y="") S SDWLERR=1 Q + .S SDWLINSN=$O(^TMP($J,"SDWLCU5",$J,+Y,0)) + .D CHE3 + Q +CHE3 ; + G CHK3:Y<0 + S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + S TAG="CHK" + Q +CHK4 ; + S SDWLI=$P(^SDWL(409.3,SDWLDA,0),U,9) + Q:'SDWLI!'$D(^SDWL(409.32,SDWLI,0)) + I $P(^SDWL(409.32,SDWLI,0),U,6)'=SDWLINST D + .D DIS + .S SDWLINSN=$P(^SDWL(409.32,SDWLI,0),U,6),SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + Q +CHK2 ; + S SDWLPO=$P($G(^SDWL(409.3,SDWLDA,0)),U,7),SDWLTM=$P($G(^SCTM(404.57,SDWLPO,0)),U,2),SDWLINSN=$P($G(^SCTM(404.51,SDWLTM,0)),U,7) + I SDWLINST'=SDWLINSN D + .S SDWLINS(409.3,SDWLDA_",",2)=SDWLINSN D UPDATE^DIE("","SDWLINS","SDWLMSG") + S TAG="CHK" + Q +DIS ;display record + S NN=$P($G(^SDWL(409.3,SDWLDA,0)),"^"),NAME=$$GET1^DIQ(2,NN_",",.01,"E") + S SSN=$$GET1^DIQ(2,NN_",",.09) + W !,"Record#: ",SDWLDA," Patient: ",NAME," (",SSN,")",!! + Q +GETINS ;Get institution + N DIR + S DIR("A")="Select Institution: " + S DIR(0)="PAO^4:EMZ",DIR("S")="I $P(^DIC(4,+Y,0),U,11)=""N"",$$TF^XUAF4(+Y)" D ^DIR + I X["^" S SDWLERR=1 Q + I Y<1 W *7,"Invalid Entry" G GETINS + S SDWLINSN=+Y + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU6.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU6.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLCU6.m (revision 623) @@ -1,51 +1,50 @@ -SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05 ; Compiled August 20, 2007 15:12:20 - ;;5.3;scheduling;**427,491**;AUG 13 1993;Build 53 - N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1 - S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END="" - D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y - D HD - F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D Q:END - .S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D Q:END - ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1="" - ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX - ..I XFLG D - ...D HD:$Y+5>IOSL Q:END - ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E") - ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y - ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58 - ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)="" S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I)) - ...W XFL W:SDWLTP1'="" "/++" - ...W:SDWLWD'="" !,?5,SDWLWD - ...S CC=CC+1 - Q:END - IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC - I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!," SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!," and running report again will correct Wait List Type field" - D CLINIC - W !!,"** End of Report **" - Q -CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message - S INST="",CLINIC=0,CC=0 - F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D - . N CL,INSTST S CL=+$G(^SDWL(409.32,CLINIC,0)) Q:CL'>0 - . S INSTST=$$CLIN^SDWLPE(CL) - . I $P(INSTST,U,6)'="" W !,*7,$P(INSTST,U,6) D - .. S CC=CC+1 - .. I CC=1 W !!!,"The following clinics need to have the institution updated in file 44:",!! - .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01) - Q -FIX ;fix corrupted Wait List Type piece 5 - S XFL1=0,SDWLTP1="" - F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J - I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q - I XFL'=1,XFL=XFL1 Q - S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX - S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")" - Q -HD ;HDR - I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END - S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF - W !,?15,"Wait List Key Field 'NULL' Report" - S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG - W !!,"STATION: "_+$$SITE^VASITE(,) - W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields" - Q +SDWLCU6 ;IOFO BAY PINES/DMR - EWL FILE 409.3 CLEANUP - print ;2/15/05 + ;;5.3;scheduling;**427**;AUG 13 1993 + N XFL,XFL1,XFLG,XDATA,END,SDWLAPTD,I,J,SDWLPD,SDWLPG,SDWLWD,SDWLTP,SDWLTP1 + S (IEN,PAT)="",(CC,SDWLPG,SDWLTP)=0,U="^",END="" + D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y + D HD + F S PAT=$O(^SDWL(409.3,"B",PAT)) Q:PAT="" D Q:END + .S IEN="" F S IEN=$O(^SDWL(409.3,"B",PAT,IEN)) Q:IEN="" D Q:END + ..S SDWLX=$G(^SDWL(409.3,IEN,0)),XFLG="",XFL=1,SDWLWD="",SDWLTP1="" + ..F I=3,5,XFL S XDATA=$P(SDWLX,U,I) S:I=5&XDATA XFL=XDATA+5 S:'XDATA XFLG=XFLG_I I I=5,XFL=1 D FIX + ..I XFLG D + ...D HD:$Y+5>IOSL Q:END + ...S NN="",NAME="" S NN=$P($G(^SDWL(409.3,IEN,0)),"^",1),NAME=$$GET1^DIQ(2,NN_",",.01,"E") + ...S SDWLAPTD=$P(SDWLX,U,16) I SDWLAPTD'="" S Y=SDWLAPTD D DD^%DT S SDWLAPTD=Y + ...W !!,IEN,?6,NAME,?40,SDWLAPTD,?54,$P(SDWLX,U,17),?58 + ...S XFL="" F I=1:1:3 Q:$E(XFLG,I)="" S XFL=XFL_$S(XFL'="":",",1:"")_$P("::INST::Type:Team:Postn:Srv/Spec:Clinic",":",$E(XFLG,I)) + ...W XFL W:SDWLTP1'="" "/++" + ...W:SDWLWD'="" !,?5,SDWLWD + ...S CC=CC+1 + Q:END + IF CC>.5 W !!,"TOTAL null field error EWL entries: "_CC + I SDWLTP>.5 W !!,"++ Missing Wait List Type and corresponding field entry (TEAM,POSITION,",!," SERVICE/SPECIALTY,CLINIC). Correct corresponding field entries",!," and running report again will correct Wait List Type field" + D CLINIC + W !!,"** End of Report **" + Q +CLINIC ;Display all clinics in file 409.32 that need to be cleaned up in file 44 in mail message + S INST="",CLINIC=0,CC=0 + F S CLINIC=$O(^SDWL(409.32,CLINIC)) Q:'CLINIC D + . S INST=$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",3,"I") + . I $$GET1^DIQ(4,INST_",",11,"I")'="N"!('$$TF^XUAF4(INST)) D + .. S CC=CC+1 + .. I CC=1 W !!!,"The following clinics need to have the institution cleaned in file 44:",!! + .. W !,?20,$$GET1^DIQ(44,+$G(^SDWL(409.32,CLINIC,0))_",",.01) + Q +FIX ;fix corrupted Wait List Type piece 5 + S XFL1=0,SDWLTP1="" + F J=6:1:9 S XDATA=$P(SDWLX,U,J) S:XDATA'="" XFL1=J + I 'XFL1 S SDWLTP=SDWLTP+1,SDWLTP1="++" Q + I XFL'=1,XFL=XFL1 Q + S $P(SDWLX,U,5)=XFL1-5,XFL=XFL1,^SDWL(409.3,IEN,0)=SDWLX + S SDWLWD="** WAIT LIST TYPE corrected to value: "_(XFL1-5)_" ("_$P("TEAM;POSITION;SERV/SPCLTY;CLINIC",";",XFL1-5)_")" + Q +HD ;HDR + I SDWLPG>0,$E(IOST,1,2)="C-" S END=$$EOP^ESPUTIL() Q:END + S SDWLPG=SDWLPG+1 W:SDWLPG'=1 @IOF + W !,?15,"Wait List Key Field 'NULL' Report" + S Y=DT D DD^%DT S SDWLPD=Y W ?57,SDWLPD,?72,"Page: ",SDWLPG + W !!,"STATION: "_DUZ(2) + W !!,"IEN Patient Name",?42,"Wait Date",?53,"STS",?58,"Null Fields" + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLE.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLE.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLE.m (revision 623) @@ -1,130 +1,130 @@ -SDWLE ;BPOI/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 - ;;5.3;scheduling;**263,415,446,524**;08/13/93;Build 29 - ; - ; - ;****************************************************************** - ; CHANGE LOG - ; - ; DATE PATCH DESCRIPTION - ; ---- ----- ----------- - ; 09JUN2005 446 Inter-Facility Transfer. - ; - ; -EN ;ENTRY POINT - INTIALIZE VARIABLES - N DTOUT,% - I $D(SDWLOPT),SDWLOPT G OPT - I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN<0 K SDWLLIST - I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN'="" S SDWLDFN=DFN D 1^VADPT S (SDWLTEM,SDWLPOS)=0 D HD,SB1 G EN1:'$D(DUOUT) W !,"PATIENT: ",VADM(1),?40,VA("PID") W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" S DIR(0)="E" D ^DIR G END - K ^TMP("SDWLD",$J) D HD - D PAT G END:DFN<0 -OPT S SDWLPCMM=0,SDWLERR=0 I $D(SDWLOPT),SDWLOPT D - .S %=2 W !,"DO YOU WISH TO PLACE THIS PATIENT ON A WAITING LIST " D YN^DICN - .I %=-1!(%=2) S SDWLERR=1 Q - I $D(SDWLOPT),SDWLOPT,SDWLERR Q - S SDWLDFN=DFN - D 1^VADPT - S (SDWLTEM,SDWLPOS)=0 -EN1 N SDWLNEW,SDWLERR,SDWLCN,SDWLWTE S SDWLNEW=0,SDWLERR=0,SDWLCN=0,SDWLWTE=0 - G:$$EN^SDWLE6(SDWLDFN,.SDWLERR) EN2 ; OG ; SD*5.3*446 ; Inter-facility transfer - D DIS - I $D(^SDWL(409.3,"B",DFN)),'SDWLCN W !!,"PATIENT: ",VADM(1),?40,VA("PID") - S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:3) - I $D(SDWLOPT),SDWLOPT,SDWLPS=3 S X="Y" G ENO - I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a Valid Number or 'N' for New." - I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1) or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a '1' or 'N' for New." - I SDWLPS=3 S DIR(0)="YAO^^S X=""Y""" S DIR("A")="Patient is not on Waiting List. Do you wish to Add Patient? Yes// " - W ! D ^DIR W ! K DIR - G END:$D(DUOUT),END:$D(DTOUT) - I SDWLPS=1 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 - .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q - I SDWLPS=2 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 - .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q -ENO I SDWLPS=3 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 - .S SDWLERR=$S(X?1"N".E:1,X?1"n".E:1,X="":0,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2) Q - I SDWLPS=1!(SDWLPS=2),X?1N.N D - .N DA,SDWLDA S (DA,SDWLDA)=$P($G(^TMP("SDWLD",$J,DFN,+X)),"~",2),SDWLEDIT="" - .; - .;LOCK DATA FILE - .; - .L +^SDWL(409.3,DA):5 I '$T W !,"ANOTHER TERMINAL IS EDITING THIS ENTRY. TRY LATER." S DUOUT=1 - .I $D(DUOUT) Q - .N SDWLINNM,SDWLSTN ; OG ; This and the following six lines added for patch 415 - .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D S DUOUT=1 Q - ..N SDWLMSG,SDWLI - ..S SDWLMSG(0)=1,SDWLMSG(SDWLMSG(0),0)="This entry is the subject of a transfer to "_SDWLINNM_" ("_SDWLSTN_"). Editing inhibited." - ..I $L(SDWLMSG(SDWLMSG(0),0))>80 D COL80^SDWLIFT(.SDWLMSG) - ..F SDWLI=1:1:SDWLMSG(0) W !,SDWLMSG(SDWLI,0) - ..Q - .D EN^SDWLE10 - .D EDIT W !!,"Editing is Completed" S SDWLERR=1 K SDWLEDIT - G END:SDWLERR - I SDWLPS=1!(SDWLPS=2),X?1"N".E!(X?1"n".E) D NEW,EDIT S SDWLNEW="" G EN2 - I SDWLPS=3 D NEW,EDIT S SDWLNEW="" -EN2 I $D(SDWLNEW),'$D(DUOUT),'SDWLERR W !!,?15,"*** Patient has been added to Wait List ***",! - K SDWLNEW,DUOUT - ; - ;UNLOCK FILE AND KILL LOCAL VARIABLES - ; - I $D(SDWLDA) L -^SDWL(409.3,SDWLDA) - ;-exit logic -EN3 D END^SDWLE113 - Q -END D END^SDWLE113 - D EN^SDWLKIL - Q - ; - ; -PAT ;SELECT PATIENT - ; - S DIC(0)="EMNZAQ",DIC=2 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,1) G PAT1:DFN<0 - S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" G PAT - S SDWLSSN=$G(VA("PID")),SDWLNAM=$G(VA(1)) -PAT1 K VADM,VAIN,VAERR,VA Q - ; -DIS ;DISPLAY DATA FOR PATIENT - ; - S SDWLHDR="Wait List Enter/Edit" - D EN^SDWLD(DFN,VA("PID"),VADM(1)) - D PCM^SDWLE1,PCMD^SDWLE1 - Q - ; -NEW ; - D NEW^SDWLE11 - Q - ; -EDIT ; - D EN^SDWLE111 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - I SDWLTYE=4 D ED4 K DIR,DIE,DIC,DR Q - I SDWLTYE=3 D ED3 K DIR,DIE,DIC,DR Q - I SDWLTYE=2 D ED2 K DIR,DIE,DIC,DR Q - I SDWLTYE=1 D ED1 K DIR,DIE,DIC,DR Q - Q -ED1 ;-team - I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE3 I '$D(DUOUT) D EN^SDWLE113 Q - Q -ED2 ;-position - I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE5 I '$D(DUOUT) D EN^SDWLE113 Q - Q -ED3 ;-specialty - D EN^SDWLE2 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - I '$D(DUOUT) D EN^SDWLE113 - D END^SDWLE113 - Q -ED4 ;-clinic - D EN^SDWLE4 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q - I '$D(DUOUT) D EN^SDWLE113 - D END^SDWLE113 - Q - ; -ED5 D END^SDWLE113 - Q -SB1 S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" S DUOUT="" - Q -HD W:$D(IOF) @IOF W !,?80-$L("Scheduling/PCMM Enter/Edit Wait List")\2,"Scheduling/PCMM Enter/Edit Wait List",!! - I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)),$D(SDWLLIST),SDWLLIST D - .W !!,"PATIENT: ",VADM(1),?40,VA("PID") - Q +SDWLE ;;IOFO BAY PINES/TEH - WAITING LIST-ENTER/EDIT;06/12/2002 ; 20 Aug 2002 2:10 PM + ;;5.3;scheduling;**263,446**;AUG 13 1993;Build 77 + ; + ; + ;****************************************************************** + ; CHANGE LOG + ; + ; DATE PATCH DESCRIPTION + ; ---- ----- ----------- + ; 09JUN2005 446 Inter-Facility Transfer. + ; + ; +EN ;ENTRY POINT - INTIALIZE VARIABLES + N DTOUT,% + I $D(SDWLOPT),SDWLOPT G OPT + I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN<0 K SDWLLIST + I $D(SDWLLIST),SDWLLIST,$D(DFN),DFN'="" S SDWLDFN=DFN D 1^VADPT S (SDWLTEM,SDWLPOS)=0 D HD,SB1 G EN1:'$D(DUOUT) W !,"PATIENT: ",VADM(1),?40,VA("PID") W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" S DIR(0)="E" D ^DIR G END + K ^TMP("SDWLD",$J) D HD + D PAT G END:DFN<0 +OPT S SDWLPCMM=0,SDWLERR=0 I $D(SDWLOPT),SDWLOPT D + .S %=2 W !,"DO YOU WISH TO PLACE THIS PATIENT ON A WAITING LIST " D YN^DICN + .I %=-1!(%=2) S SDWLERR=1 Q + I $D(SDWLOPT),SDWLOPT,SDWLERR Q + S SDWLDFN=DFN + D 1^VADPT + S (SDWLTEM,SDWLPOS)=0 +EN1 N SDWLNEW,SDWLERR,SDWLCN,SDWLWTE S SDWLNEW=0,SDWLERR=0,SDWLCN=0,SDWLWTE=0 + G:$$EN^SDWLE6(SDWLDFN,.SDWLERR) EN2 ; OG ; SD*5.3*446 ; Inter-facility transfer + D DIS + I $D(^SDWL(409.3,"B",DFN)),'SDWLCN W !!,"PATIENT: ",VADM(1),?40,VA("PID") + S SDWLPS=$S(SDWLCN>1:1,SDWLCN=1:2,1:3) + I $D(SDWLOPT),SDWLOPT,SDWLPS=3 S X="Y" G ENO + I SDWLPS=1 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1-"_SDWLCN_") or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a Valid Number or 'N' for New." + I SDWLPS=2 S DIR(0)="FOA^^" S DIR("A")="Select Wait List (1) or Enter 'N' for New or '^' to Quit ? ",DIR("?")="Enter a '1' or 'N' for New." + I SDWLPS=3 S DIR(0)="YAO^^S X=""Y""" S DIR("A")="Patient is not on Waiting List. Do you wish to Add Patient? Yes// " + W ! D ^DIR W ! K DIR + G END:$D(DUOUT),END:$D(DTOUT) + I SDWLPS=1 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 + .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q + I SDWLPS=2 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 + .S SDWLERR=$S(X?1"N".E:0,X?1"n".E:0,X="":2,$D(DUOUT):1,X["^":1,$D(^TMP("SDWLD",$J,DFN,+X)):0,1:2) Q +ENO I SDWLPS=3 D G EN3:SDWLERR=1 I SDWLERR=2 W *7," ??" G EN1 + .S SDWLERR=$S(X?1"N".E:1,X?1"n".E:1,X="":0,X?1"Y".E:0,X?1"y".E:0,$D(DUOUT):1,X["^":1,1:2) Q + I SDWLPS=1!(SDWLPS=2),X?1N.N D + .N DA,SDWLDA S (DA,SDWLDA)=$P($G(^TMP("SDWLD",$J,DFN,+X)),"~",2),SDWLEDIT="" + .; + .;LOCK DATA FILE + .; + .L +^SDWL(409.3,DA):5 I '$T W !,"ANOTHER TERMINAL IS EDITING THIS ENTRY. TRY LATER." S DUOUT=1 + .I $D(DUOUT) Q + .N SDWLINNM,SDWLSTN ; OG ; This and the following six lines added for patch 415 + .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D S DUOUT=1 Q + ..N SDWLMSG,SDWLI + ..S SDWLMSG(0)=1,SDWLMSG(SDWLMSG(0),0)="This entry is the subject of a transfer to "_SDWLINNM_" ("_SDWLSTN_"). Editing inhibited." + ..I $L(SDWLMSG(SDWLMSG(0),0))>80 D COL80^SDWLIFT(.SDWLMSG) + ..F SDWLI=1:1:SDWLMSG(0) W !,SDWLMSG(SDWLI,0) + ..Q + .D EN^SDWLE10 + .D EDIT W !!,"Editing is Completed" S SDWLERR=1 K SDWLEDIT + G END:SDWLERR + I SDWLPS=1!(SDWLPS=2),X?1"N".E!(X?1"n".E) D NEW,EDIT S SDWLNEW="" G EN2 + I SDWLPS=3 D NEW,EDIT S SDWLNEW="" +EN2 I $D(SDWLNEW),'$D(DUOUT),'SDWLERR W !!,?15,"*** Patient has been added to Wait List ***",! + K SDWLNEW,DUOUT + ; + ;UNLOCK FILE AND KILL LOCAL VARIABLES + ; + I $D(SDWLDA) L -^SDWL(409.3,SDWLDA) + ;-exit logic +EN3 D END^SDWLE113 + Q +END D END^SDWLE113 + D EN^SDWLKIL + Q + ; + ; +PAT ;SELECT PATIENT + ; + S DIC(0)="EMNZAQ",DIC=2 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,1) G PAT1:DFN<0 + S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" W !,*7,"PATIENT'S DATE OF DEATH HAS BEEN RECORDED" G PAT + S SDWLSSN=$G(VA("PID")),SDWLNAM=$G(VA(1)) +PAT1 K VADM,VAIN,VAERR,VA Q + ; +DIS ;DISPLAY DATA FOR PATIENT + ; + S SDWLHDR="Wait List Enter/Edit" + D EN^SDWLD(DFN,VA("PID"),VADM(1)) + D PCM^SDWLE1,PCMD^SDWLE1 + Q + ; +NEW ; + D NEW^SDWLE11 + Q + ; +EDIT ; + D EN^SDWLE111 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + I SDWLTYE=4 D ED4 K DIR,DIE,DIC,DR Q + I SDWLTYE=3 D ED3 K DIR,DIE,DIC,DR Q + I SDWLTYE=2 D ED2 K DIR,DIE,DIC,DR Q + I SDWLTYE=1 D ED1 K DIR,DIE,DIC,DR Q + Q +ED1 ;-team + I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE3 I '$D(DUOUT) D EN^SDWLE113 Q + Q +ED2 ;-position + I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE5 I '$D(DUOUT) D EN^SDWLE113 Q + Q +ED3 ;-specialty + D EN^SDWLE2 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + I '$D(DUOUT) D EN^SDWLE113 + D END^SDWLE113 + Q +ED4 ;-clinic + D EN^SDWLE4 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + D EN^SDWLE110 I $D(DUOUT) D END^SDWLE113:'$D(SDWLEDIT) Q + I '$D(DUOUT) D EN^SDWLE113 + D END^SDWLE113 + Q + ; +ED5 D END^SDWLE113 + Q +SB1 S X=$$GET1^DIQ(2,DFN_",",".351") I X'="" S DUOUT="" + Q +HD W:$D(IOF) @IOF W !,?80-$L("Scheduling/PCMM Enter/Edit Wait List")\2,"Scheduling/PCMM Enter/Edit Wait List",!! + I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)),$D(SDWLLIST),SDWLLIST D + .W !!,"PATIENT: ",VADM(1),?40,VA("PID") + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLI.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLI.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLI.m (revision 623) @@ -1,168 +1,165 @@ -SDWLI ;BPOI/TEH - DISPLAY PENDING APPOINTMENTS;6/1/05 - ;;5.3;scheduling;**263,327,394,446,524**;08/13/93;Build 29 - ; - ; - ;****************************************************************** - ; CHANGE LOG - ; - ; DATE PATCH DESCRIPTION - ; ---- ----- ----------- - ; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION - ; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1 - ; 08/07/2006 SD*5.3*446 proceed only when DFN defined - ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER - ; - ; -EN ;NEW AND INITIALIZE VARIABLES - S SDWLERR=0 - I $D(SDWLLIST),SDWLLIST D Q:SDWLERR - .I '$G(DFN) S SDWLERR=1 Q - .I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q - I $D(DUOUT) G END - I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1 - K DIR,DIC,DR,DIE,VADM - S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) - ; - ;OPTION HEADER - ; - D HD - ; - ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0). - ; - D SEL G EN:$D(DUOUT) - D PAT Q:'$D(SDWLDFN) - G END:SDWLDFN<0,END:SDWLDFN="" - Q:$D(DUOUT) -EN1 K DIR,DIC,DR,DIE,SDWLDRG - D GETFILE - D DISP G EN:'$D(DUOUT) - D END - Q -PAT ;PATIENT LOOK-UP - ;PATCH SD*5.3*524 - SET DIC("S") FOR SCREEN OF OPEN/CLOSED ENTRIES - S DIC("S")="I $D(SDWLY),SDWLY,$P(^SDWL(409.3,+Y,0),U,17)=""O""" - S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2) - G PATEND:SDWLDFN="" - Q:Y<0 - Q:$D(DUOUT) - D 1^VADPT -PATEND Q - ; - ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES - ; -SEL K SDWLDRG S DIR(0)="Y" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists",DIR("B")="YES" - S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records." - W ! D ^DIR S SDWLY=Y W ! - I X["^" S DUOUT=1 - I SDWLY=0 D SEL1 - Q -SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y - S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A") - Q - ; -GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE - ; - K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D - .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q - .I '$P(SDWLDATA,U,3) Q - .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D ;app data - ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23) - .N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1 - .I $D(^SDWL(409.3,SDWLDA,"DIS")) D - ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2) - ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1) - ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3) - .I $D(^SDWL(409.3,SDWLDA,"DNR")) D - ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15) - ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3) - ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I") - .S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2) - .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D I SDNOK Q - ..S SDNOK=0 - ..I SDWLDTSDWLEDT) S SDNOK=1 Q - .; - .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD - .; - .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA - .I $D(SDWLDISX) D - ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT - ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP - ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP - .I $D(SDREM) D - ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD - .S ^TMP("SDWLI",$J)=SDWLCNT - .K SDWLDISX,SDREM - Q - ; -DISP ;Display Wait List Data - S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q - F S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT="" D I $D(DUOUT) Q - .N SDWLDISX,SDWLR,SDWLCLPT - .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS")) - .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D - ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4) - .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11) - .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"") - .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8),SDWLCOM=$P($P(X,U,18),"~",1) - .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D - ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3) - .S SDWLDT=$P(X,U,2),YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_"/"_DD_"/"_YY - .S SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY - .;PATCH SD*5.3*394 See Note. - .N SDWLSCP - .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2) - .W !,"# ",$J(SDWLCNT,3),! - .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP - .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X - .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1 - .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP) - .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN) - .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X - .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD - .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV) - .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM - .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D - ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2) - .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D - ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC - ..W !,"Non Removal entry date - ",SDREMDD - .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D - ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ) - .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D - ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y - ..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC - ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01) - ..W !?3,"Appt Institution: ",SDAIN - ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01) - ..W ?40,"Appt Specialty: ",SDCR - ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic" - .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I") ; SD*5.3*446 - .D:SDWLCLPT ; SD*5.3*446 - ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8) - ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")" - ..Q - .; Inter-facility Transfer. SD*5.3*446 - .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS - .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP") - .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN - .W !,"*****",! K DIR S DIR(0)="E" D ^DIR D - ..I X["^" S DUOUT=1 Q - ..I 'Y S DUOUT=1 Q - ..D HD - Q -HD ;Header - W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",! - ;SD*5.3*327 - Correct undefined. - I '$D(SDWLDFN) W !! Q - N DFN S DFN=SDWLDFN D DEM^VADPT - W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID") - W !! - K DUOUT - Q -END ; - K DIR,DIC,DR,DIE,SDWLDFN,DUOUT - K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX - K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY - K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP - K SDREMD,SDREMDD,SDREMR,SDREMRC,SDREMU,MM,SDWLEDT,SDWLLIST,SDWLST,SDWLX,VA,X,Y,YY - Q +SDWLI ;IOFO BAY PINES/TEH - DISPLAY PENDING APPOINTMENTS ; 6/1/05 12:56pm ; Compiled April 16, 2007 10:00:47 + ;;5.3;scheduling;**263,327,394,446**;AUG 13 1993;Build 77 + ; + ; + ;****************************************************************** + ; CHANGE LOG + ; + ; DATE PATCH DESCRIPTION + ; ---- ----- ----------- + ; 04/22/2005 SD*5.3*327 DISPLAY APPOINTMENT INFORMATION + ; 04/22/2005 SD*5.3*327 UNDEFINED ERROR HD+1 + ; 08/07/2006 SD*5.3*446 proceed only when DFN defined + ; 04/14/2006 SD*5.3*446 INTER-FACILITY TRANSFER + ; + ; +EN ;NEW AND INITIALIZE VARIABLES + S SDWLERR=0 + I $D(SDWLLIST),SDWLLIST D Q:SDWLERR + .I '$G(DFN) S SDWLERR=1 Q + .I $D(DFN),DFN'="",'$D(^SDWL(409.3,"B",DFN)) D HD W *7,!,"This Patient has NO entries on the Electronic Wait List." S DIR(0)="E" D ^DIR S DUOUT=1 Q + I $D(DUOUT) G END + I 'SDWLERR,$D(SDWLLIST),SDWLLIST D 1^VADPT,DEM^VADPT S SDWLDFN=DFN D HD K DIR,DIC,DR,DIE,VADM S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) G EN1 + K DIR,DIC,DR,DIE,VADM + S (SDWLBDT,SDWLEDT)="" K ^TMP("SDWLI",$J) + ; + ;OPTION HEADER + ; + D HD + ; + ;PATIENT LOOK-UP FROM WAIT LIST PATIENT FILE (^SDWL(409.3,IEN,0). + ; + D PAT Q:'$D(SDWLDFN) + G END:SDWLDFN<0,END:SDWLDFN="" + Q:$D(DUOUT) +EN1 K DIR,DIC,DR,DIE,SDWLDRG + D SEL G EN:$D(DUOUT) + D GETFILE + D DISP G EN:'$D(DUOUT) + D END + Q +PAT ;PATIENT LOOK-UP + S DIC(0)="EMNQA",DIC=409.3 D ^DIC S (SDWLDFN,DFN)=$P(Y,U,2) + G PATEND:SDWLDFN="" + Q:Y<0 + Q:$D(DUOUT) + D 1^VADPT +PATEND Q + ; + ;PROMPT FOR DISPLAY 'OPEN' WAITING LIST ONLY OR PROMPT FOR BEGINNING AND ENDING DATES + ; +SEL K SDWLDRG S DIR(0)="YAO^^" S DIR("A")="Do You Want to View Only 'OPEN' Wait Lists? Yes// " + S DIR("?")="'Yes' for 'Open' and these Patient Record have not been dispositioned and 'No' for all Records." + W ! D ^DIR S SDWLY=Y W ! + I X["^" S DUOUT=1 + I SDWLY=0 D SEL1 + Q +SEL1 K DIR,%DT(0) S SDWLDISC="",%DT="AE",%DT("A")="Start with Date Entered: " D ^%DT G SEL:Y<1 S SDWLBDT=Y + S %DT(0)=SDWLBDT,%DT("A")="End with Date Entered: " D ^%DT G SEL1:Y<1 S SDWLEDT=Y,SDWLDRG="" K %DT(0),%DT("A") + Q + ; +GETFILE ;GET DATA - OPTIONAL DATE RANGE IF SDWLDBT AND SDWLEDT VALID DATE RANGE + ; + K ^TMP("SDWLI",$J),SDWLDISX S SDWLDA=0,SDWLCNT=0 F S SDWLDA=$O(^SDWL(409.3,"B",SDWLDFN,SDWLDA)) Q:SDWLDA="" D + .S SDWLDATA=$G(^SDWL(409.3,SDWLDA,0)) I '$D(SDWLDRG),$P(SDWLDATA,U,17)["C" Q + .I '$P(SDWLDATA,U,3) Q + .N SDWLAPP S SDWLAPP="" I $D(^SDWL(409.3,SDWLDA,"SDAPT")) S SDWLAPP=^("SDAPT") D ;app data + ..S SDWLAPP=SDWLAPP_"~"_$P(SDWLDATA,U,23) + .N SDOP,SDOP1 S SDOP="" I $D(^SDWL(409.3,SDWLDA,1)) S SDOP=^(1),SDOP1=$$GET1^DIQ(409.3,SDWLDA_",",29),$P(SDOP,U)=SDOP1 + .I $D(^SDWL(409.3,SDWLDA,"DIS")) D + ..S SDWLDISX=$G(^SDWL(409.3,SDWLDA,"DIS")),SDWLDIS=$P(SDWLDISX,U,3),SDWLDDUZ=$P(SDWLDISX,U,2) + ..S SDWLDDT=$P(^SDWL(409.3,SDWLDA,"DIS"),U,1) + ..S SDWLDIDT="" I SDWLDDT'="" S SDWLDIDT=$E(SDWLDDT,4,5)_"/"_$E(SDWLDDT,6,7)_"/"_$E(SDWLDDT,2,3) + .I $D(^SDWL(409.3,SDWLDA,"DNR")) D + ..S SDREM=$G(^SDWL(409.3,SDWLDA,"DNR")) S SDREMD=$P(SDWLDATA,U,14),SDREMU=$P(SDWLDATA,U,15) + ..S SDREMDD="" I SDREMD'="" S SDREMDD=$E(SDREMD,4,5)_"/"_$E(SDREMD,6,7)_"/"_$E(SDREMD,2,3) + ..S SDREMR=$$GET1^DIQ(409.3,SDWLDA_",",18),SDREMRC=$$GET1^DIQ(409.3,SDWLDA_",",18.1,"I") + .S SDWLST=$P(SDWLDATA,U,6),SDWLSP=$P(SDWLDATA,U,7),SDWLSS=$P(SDWLDATA,U,8),SDWLSC=$P(SDWLDATA,U,9),SDWLDT=$P(SDWLDATA,U,2) + .S SDWLPROV=$P(SDWLDATA,U,13) I $D(SDWLDRG) D I SDNOK Q + ..S SDNOK=0 + ..I SDWLDTSDWLEDT) S SDNOK=1 Q + .; + .;IF STATUS IS CLOSED DO NOT DISPLAY RECORD + .; + .S SDWLCNT=SDWLCNT+1,^TMP("SDWLI",$J,SDWLCNT)=SDWLDATA_"~"_SDWLDA + .I $D(SDWLDISX) D + ..S ^TMP("SDWLI",$J,SDWLCNT,"DIS")=SDWLDIS_"^"_SDWLDDUZ_"^"_SDWLDIDT + ..I SDWLAPP>0 S ^TMP("SDWLI",$J,SDWLCNT,"SDAPT")=SDWLAPP + ..I SDOP'="" S ^TMP("SDWLI",$J,SDWLCNT,"SDOP")=SDOP + .I $D(SDREM) D + ..S ^TMP("SDWLI",$J,SDWLCNT,"REM")=SDREMR_U_SDREMRC_U_SDREMU_U_SDREMDD + .S ^TMP("SDWLI",$J)=SDWLCNT + .K SDWLDISX,SDREM + Q + ; +DISP ;Display Wait List Data + S (SDWLDT,SDWLCNT,SDWLCN)="",SDWLCT=$G(^TMP("SDWLI",$J)) I 'SDWLCT W !!,"No 'OPEN' Wait List Records to Display.",!! K DIR S DIR(0)="E" D ^DIR S DUOUT="" Q + F S SDWLCNT=$O(^TMP("SDWLI",$J,SDWLCNT)) Q:SDWLCNT="" D I $D(DUOUT) Q + .N SDWLDISX,SDWLR,SDWLCLPT + .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) S SDWLDISX=$G(^TMP("SDWLI",$J,SDWLCNT,"DIS")) + .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) S SDWLR=$G(^TMP("SDWLI",$J,SDWLCNT,"REM")) D + ..S SDREMR=$P(SDWLR,U),SDREMRC=$P(SDWLR,U,2),SDREMU=$P(SDWLR,U,3),SDREMDD=$P(SDWLR,U,4) + .S X=$G(^TMP("SDWLI",$J,SDWLCNT)),SDWLDA=$P(X,"~",2),SDWLIN=$P(X,U,3),SDWLCL=$P(X,U,4),SDWLTY=$P(X,U,5),SDWLPRI=$P(X,U,11) + .S SDWLTYP=$S(SDWLTY=1:$P(X,U,6),SDWLTY=2:$P(X,U,7),SDWLTY=3:$P(X,U,8),SDWLTY=4:$P(X,U,9),1:"") + .S SDWLTYN=$S(SDWLTY=1:5,SDWLTY=2:6,SDWLTY=3:7,SDWLTY=4:8,1:0),SDWLCOM=$P($P(X,U,18),"~",1) + .S SDWLDUZ=$P(X,U,10),SDWLPRV=$P(X,U,12),SDWLPROV=$P(X,U,13),SDWLX=$P(X,"~",3) D + ..I $D(SDWLDISX) S SDWLDIS=$P(SDWLDISX,U,1),SDWLDDUZ=$P(SDWLDISX,U,2),SDWLDIDT=$P(SDWLDISX,U,3) + .S SDWLDT=$P(X,U,2),YY=$E(SDWLDT,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDT,4,5),DD=$E(SDWLDT,6,7),SDWLDTP=MM_"/"_DD_"/"_YY + .S SDWLDTD=$P(X,U,16),YY=$E(SDWLDTD,1,3)+1700,YY=$E(YY,3,4),MM=$E(SDWLDTD,4,5),DD=$E(SDWLDTD,6,7),SDWLDTD=MM_"/"_DD_"/"_YY + .;PATCH SD*5.3*394 See Note. + .N SDWLSCP + .S SDWLSCP=+$P($G(^SDWL(409.3,SDWLDA,"SC")),U,2) + .W !,"# ",$J(SDWLCNT,3),! + .W !,"Wait List - ",$$EXTERNAL^DILFD(409.3,4,,SDWLTY),?55,"Date Entered - ",SDWLDTP + .W !,?15 S X=$$EXTERNAL^DILFD(409.3,SDWLTYN,,SDWLTYP) W X + .S SDWLP=0 I SDWLPRI W !,"Priority - ",$$EXTERNAL^DILFD(409.3,10,,SDWLPRI) S SDWLP=1 + .I $D(SDWLSCP) W !,"Service Connected Priority - ",$$EXTERNAL^DILFD(409.3,15,,SDWLSCP) + .W:SDWLP ?15 W:'SDWLP ! W "Institution - ",$$EXTERNAL^DILFD(409.3,2,,SDWLIN) + .W !,"Entered by - " S X=$$EXTERNAL^DILFD(409.3,9,,SDWLDUZ) W X + .S SDWRB=0 I SDWLPRV W !,"Requested By - ",$$EXTERNAL^DILFD(409.3,11,,SDWLPRV),?55,"Date Desired - ",SDWLDTD + .I SDWLPRV=1 W !,"Provider - ",$$EXTERNAL^DILFD(409.3,12,,SDWLPROV) + .I $D(SDWLCOM),SDWLCOM'="" W !,"Comments - ",SDWLCOM + .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDOP")) N SDOP S SDOP=^("SDOP") W !,"Reopen Reason: ",$P(SDOP,U) D + ..I $P(SDOP,U,2)'="" W !,"Reopen comment: ",$P(SDOP,U,2) + .I $D(^TMP("SDWLI",$J,SDWLCNT,"REM")) W !,"Non Removal Reason - ",SDREMR,!,"Non Remove Reason entered by - ",$$GET1^DIQ(200,SDREMU_",",.01,"I") D + ..I $L(SDREMRC)>0 W !,"Non Removal Comment - ",SDREMRC + ..W !,"Non Removal entry date - ",SDREMDD + .I $D(^TMP("SDWLI",$J,SDWLCNT,"DIS")) W !,"Disposition - ",$$EXTERNAL^DILFD(409.3,21,,SDWLDIS),?51,"Disposition Date - ",SDWLDIDT D + ..W !,"Dispositioned by - ",$$EXTERNAL^DILFD(409.3,20,,SDWLDDUZ) + .I $D(^TMP("SDWLI",$J,SDWLCNT,"SDAPT")) N SDAP S SDAP=^("SDAPT") D + ..W !,"Appointment scheduled for " S Y=$P(SDAP,"~",2) D DD^%DT W Y + ..W !?3,"Made on: " S Y=+SDAP D DD^%DT W Y,?30,"For clinic: " N SDC S SDC=$P(SDAP,U,2) S SDC=$$GET1^DIQ(44,SDC_",",.01) W SDC + ..N SDAIN S SDAIN=$P(SDAP,U,3),SDAIN=$$GET1^DIQ(4,SDAIN_",",.01) + ..W !?3,"Appt Institution: ",SDAIN + ..N SDCR S SDCR=$P(SDAP,U,4),SDCR=$$GET1^DIQ(40.7,SDCR_",",.01) + ..W ?40,"Appt Specialty: ",SDCR + ..N SAPS S SAPS=$P(SDAP,U,8),SAPS=$P(SAPS,"~") I SAPS="CC" W !,"Appointment Status: Canceled by Clinic" + .S SDWLCLPT=$$GET1^DIQ(409.3,SDWLDA,37,"I") ; SD*5.3*446 + .D:SDWLCLPT ; SD*5.3*446 + ..W !,"Clinic changed from: ",$$GET1^DIQ(409.3,SDWLCLPT,8) + ..W:SDWLIN'=$$GET1^DIQ(409.3,SDWLCLPT,2,"I") " (",$$GET1^DIQ(409.3,SDWLCLPT,2),")" + ..Q + .; Inter-facility Transfer. SD*5.3*446 + .I $$GETTRN^SDWLIFT1(SDWLDA,.SDWLINNM,.SDWLSTN) D ENS^%ZISS W !,IOINHI,"In transfer to ",SDWLINNM," (",SDWLSTN,")",IOINORM D KILL^%ZISS + .D GETS^DIQ(409.3,SDWLDA,"32;33;34;36;38;39","TMP") + .K SDWLIN,SDWLCL,SDWLTY,SDWLPRI,SDWLDUZ,SDWLPRV,SDWLDT,SDWLDTD,SDWLDIS,SDWLDIDT,SDWLTYN,SDWLCOM,SDWLPROV,SDWLDISX,DIR,DIE,DR,SDWLINNM,SDWLSTN + .W !,"*****",! K DIR S DIR(0)="E" D ^DIR D + ..I X["^" S DUOUT=1 Q + ..I 'Y S DUOUT=1 Q + ..D HD + Q +HD ;Header + W:$D(IOF) @IOF W !!,?80-$L("Wait List - Inquiry")\2,"Wait List - Inquiry ",! + ;SD*5.3*327 - Correct undefined. + I '$D(SDWLDFN) W !! Q + N DFN S DFN=SDWLDFN D DEM^VADPT + W:$D(VADM) !,VADM(1),?40 I $D(VA("PID")) W VA("PID") + W !! + K DUOUT + Q +END ; + K DIR,DIC,DR,DIE,SDWLDFN,DUOUT + K SDNOK,SDWLBDT,SDWLCL,SDWLCN,SDWLCNT,SDWLCOM,SDWLCT,SDWLDA,SDWLDATA,SDWLDDT,SDWLDDUZ,SDWLDFN,SDWLDIDT,SDWLDIS,SDWLDISX + K SDWLDRG,SDWLDT,SDWLDTD,SDWLDTP,SDWLDUZ,SDLWEDT,SDWLIN,SDLWP,SDWLPRI,SDWLPROV,SDLWPRV,SDWLSC,SDWLSP,SDWLSS,SDLWST,SDWLTY + K SDWLTYN,SDSWLTYP,SDLWX,SDWLY,SDWRB,SDWLBDT,SDWLDISC,SDWLERR,SDWLPRON,SDXSCAT,SDWLP,SDWLTYP + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLPE.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLPE.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLPE.m (revision 623) @@ -1,133 +1,83 @@ -SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002 ; Compiled April 22, 2008 14:13:00 - ;;5.3;scheduling;**263,280,288,397,491**;AUG 13 1993;Build 53 - ; - ;SD/491 - identify clinic institution through DIVISION ---> INSTITUTION path -EN ; - ;OPTION HEADER - ; - D HD - ; - ;SELECT FILE TO EDIT - ; -EN1 D SEL G END:X["^",END:X="" - ; - ;EDIT PARAMETER FILE - ; - D EDIT G EN:'$D(Y) - G END - Q - ; -SEL ;SELECT PARAMETER FILE - S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location" - S DIR("L",1)="Select one of the following:" - S DIR("L",2)="" - S DIR("L",3)=" 1. Wait List Service/Specialty (409.31)" - S DIR("L")=" 2. Wait List Clinic Location (409.32)" - D ^DIR S SDWLF=X - K DIR,DILN,DINDEX - Q -EDIT ;EDIT FILE PARAMETERS - I SDWLF=1 D SB1 Q:$D(DUOUT) - I SDWLF=2 D SB2 Q:$D(DUOUT) - Q -SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)" - D ^DIC - I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q - Q:Y<0 Q:$D(DUOUT) S SDWLDSS=+Y - I '$D(^SDWL(409.31,"B",SDWLDSS)) D - .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN - S DA=$O(^SDWL(409.31,"B",SDWLDSS,"")) -SB1A S DIR(0)="PAO^4:EMZ" D ^DIR - I X="" W *7," Required" G SB1A - I X["^" D:'$D(^SDWL(409.31,DA,"I")) S DUOUT=1 Q - .S DIK="^SDWL(409.31," D ^DIK - S X=$$GET1^DIQ(4,+Y_",",11) - I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A - I '$D(^SDWL(409.31,DA,"I","B",+Y)) D - .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y - I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0)) - K DIC,DIE,DIR,DR - W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE - I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D - .W *7,!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted." - .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D - ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK - K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV - Q -SB2 N STR,INST,DIC,SDWLSC,SDWLSTOP S SDWLSTOP=0 - W ! S DIC(0)="AEMNZ",DIC("A")="Select Clinic: ",DIC=44 - S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2)" - S DIC("W")="S STR=$$CLIN^SDWLPE(+Y) I STR W ?50,""- "",$E($P(STR,U,3),1,25),""("",$P(STR,U,2),"")""" - D ^DIC I Y<1 K DIC,DA Q - Q:$D(DUOUT) S SDWLSC=+Y S INST=+STR ;$$CLIN(SDWLSC) - I $P(STR,U,6)'="" W !,*7,$P(STR,U,6) G SB2 - N SDANEW S SDANEW="" - I '$D(^SDWL(409.32,"B",SDWLSC)) D - .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN - .N DA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) S SDANEW=DA - .S DIE="^SDWL(409.32,",DR=".02////^S X=INST" D ^DIE - N DA,SDA S DA=$O(^SDWL(409.32,"B",SDWLSC,"")),SDA=DA - S DR="1",DIE="^SDWL(409.32," D ^DIE - I SDANEW,'X D D ESB2 H 1 G SB2 - .W *7,!!,"This ENTRY requires an ACTIVATION DATE. ENTRY deleted." - .S DA=SDANEW S DIK="^SDWL(409.32," D ^DIK - I X S DR="2////^S X=DUZ" D ^DIE - N DIC - S SDWLSCN=$P($G(^SDWL(409.32,SDA,0)),U,1) D Q:SDWLSTOP - .I $D(^SDWL(409.3,"SC",SDWLSCN)) D - ..S SDWLN="",SDWLCNT=0 F S SDWLN=$O(^SDWL(409.3,"SC",SDWLSCN,SDWLN)) Q:SDWLN="" D - ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1 - ..I SDWLSTOP W !,"This Clinic has Patients on the Wait List and can not be inactivated." H 2 Q - .S DR="4////^S X=DUZ" D ^DIE - S DR="3",DIE="^SDWL(409.32," D ^DIE -ESB2 ; - K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF - Q -SWT ;SWITCH FOR INACTIVATION OF PARAMETER FILE - Q -HD ;HEADER - W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",! - W !,?80-$L("------------------------------")\2,"------------------------------",! -END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y - Q -CLIN(CL) ;identify clinic institution through DIVISON ----> INSTITUTION path. - ; function to return: - ; 1 2 3 4 5 6 7 - ; - Institution pointer to ^DIC(4 _U_ STATION number (# 99) _U_ INST Name _U_ DIV Pointer to ^DG(40.8 _U_N/L_U_Message_U_TYPE - ; ( INST^STA NUM^SNAM^DIV^N/L^MESS^TYPE ) - ; N/L - N -National/L -Local - ; TYPE - type of entry in file # 44 (field #2) - ; C:CLINIC - ; M:MODULE - ; W:WARD - ; Z:OTHER LOCATION - ; N:NON-CLINIC STOP - ; F:FILE AREA - ; I:IMAGING - ; OR:OPERATING ROOM - ; - ; with optional Message: - ; - ; if STA="" - ; - INST^^SNAM^DIV^N/L^' - No Station Number on file' ^ TYPE - ; or - ; - 0^^^DIV^^' - No Institution has been identified '^ TYPE - ; - 0^^^-1^^' - No Division has been identified' ^ TYPE - ; - ; if entry is inactivated: - ; - ; - INST^^SNAM^DIV^N/L^' - Inactive treating medical facility' ^ TYPE - ; - -1^^^^^' - No clinic on file' ^ - ; - I +CL=0!'$D(^SC(+CL)) Q -1_"^^^^^ - No clinic on file^" - N SDWMES,STN,DIV,INS,SNL,STR,SNAM S SDWMES="",STN="" - N TYPE S TYPE=$$GET1^DIQ(44,CL_",",2,"E") - S DIV=+$$GET1^DIQ(44,CL_",",3.5,"I") - I DIV=0 S SDWMES=" - No Division has been identified" Q 0_"^^^"_-1_"^^"_SDWMES_U_TYPE - S INS=+$$GET1^DIQ(40.8,DIV_",",.07,"I") - I INS=0 S SDWMES=" - No Institution has been identified" Q 0_"^^^"_DIV_"^^"_SDWMES_U_TYPE - E S STR=$$NS^XUAF4(INS),STN=$P(STR,U,2),SNAM=$P(STR,U) ;station number and name - I STN="" S SDWMES=" - No Station Number on file" - I '$$TF^XUAF4(INS) S SDWMES=SDWMES_" - Inactive treating medical facility" - S SNL=$$GET1^DIQ(4,INS_",",11,"I") - Q INS_U_STN_U_SNAM_U_DIV_U_SNL_U_SDWMES_U_TYPE +SDWLPE ;IOFO BAY PINES/TEH - WAIT LIST - PARAMETER WAIT LIST ENTER/EDIT ;20 Aug 2002 + ;;5.3;scheduling;**263,280,288,397**;AUG 13 1993 + ; + ; +EN ; + ;OPTION HEADER + ; + D HD + ; + ;SELECT FILE TO EDIT + ; +EN1 D SEL G END:X["^",END:X="" + ; + ;EDIT PARAMETER FILE + ; + D EDIT G EN:'$D(Y) + G END + Q + ; +SEL ;SELECT PARAMETER FILE + S DIR(0)="SO^1:Wait List Service/Specialty File;2:Wait List Clinic Location" + S DIR("L",1)="Select one of the following:" + S DIR("L",2)="" + S DIR("L",3)=" 1. Wait List Service/Specialty (409.31)" + S DIR("L")=" 2. Wait List Clinic Location (409.32)" + D ^DIR S SDWLF=X + K DIR,DILN,DINDEX + Q +EDIT ;EDIT FILE PARAMETERS + I SDWLF=1 D SB1 Q:$D(DUOUT) + I SDWLF=2 D SB2 Q:$D(DUOUT) + Q +SB1 S DIC(0)="AEQMZ",DIC("A")="Select DSS ID: ",DIC="^DIC(40.7,",DIC("S")="I '$P(^DIC(40.7,+Y,0),U,3)" + D ^DIC + I X["^" I $D(DA),'$D(^SDWL(409.31,DA,"I")) S DIK="^SDWL(409.31," D ^DIK S DUOUT=1 Q + Q:Y<0 Q:$D(DUOUT) S SDWLDSS=+Y + I '$D(^SDWL(409.31,"B",SDWLDSS)) D + .S DIC(0)="LX",X=SDWLDSS,DIC="^SDWL(409.31," K DO D FILE^DICN + S DA=$O(^SDWL(409.31,"B",SDWLDSS,"")) +SB1A S DIR(0)="PAO^4:EMZ" D ^DIR + I X="" W *7," Required" G SB1A + I X["^" D:'$D(^SDWL(409.31,DA,"I")) S DUOUT=1 Q + .S DIK="^SDWL(409.31," D ^DIK + S X=$$GET1^DIQ(4,+Y_",",11) + I X'["N"!'$$TF^XUAF4(+Y) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB1A + I '$D(^SDWL(409.31,DA,"I","B",+Y)) D + .S DA(1)=DA,DIC="^SDWL(409.31,"_DA(1)_","_"""I"""_",",DIC("P")=409.311,X=+Y K D0 D FILE^DICN I +Y S DA=+Y + I $D(^SDWL(409.31,DA,"I","B",+Y)) S DA(1)=DA,DA=$O(^(+Y,0)) + K DIC,DIE,DIR,DR + W ! S DR="1;3",DIE="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIE + I $P(^SDWL(409.31,DA(1),"I",DA,0),U,2)="" D + .W *7," This ENTRY requires an ACTIVATION DATE. ENTRY deleted." + .S DIK="^SDWL(409.31,"_DA(1)_","_"""I"""_"," D ^DIK I '$P(^SDWL(409.31,DA(1),"I",0),U,3) D + ..S DIK="^SDWL(409.31,",DA=DA(1) D ^DIK + K DA,DA(1),SDWLDSS,DIC,DR,DIE,DI,DIEDA,DIG,DIH,DIIENS,DIR,DIU,DIV + Q +SB2 S SDWLSTOP=0 + W ! S DIC(0)="AEQMNZ",DIC("A")="Select Clinic: ",DIC=44 + S DIC("S")="S SDWLX=$G(^SC(+Y,0)),SDWLY=$G(^(""I"")) I $P(SDWLX,U,3)=""C"",$P(SDWLY,U,1)'>$P(SDWLY,U,2) I $P(^SC(+Y,0),U,4)" + S DIC("W")="I $P(^SC(+Y,0),U,4) W ?50,""- "",$E($P(^DIC(4,$P(^SC(+Y,0),U,4),0),U,1),1,25)" + D ^DIC Q:Y<1 Q:$D(DUOUT) S SDWLSC=+Y + S INST=$$GET1^DIQ(44,+Y,3,"I") + S X=$$GET1^DIQ(4,+INST_",",11) I X'["N"!'$$TF^XUAF4(+INST) W !,*7,"Invalid Entry. Must be 'National' Institution." G SB2 + I '$D(^SDWL(409.32,"B",SDWLSC)) D + .S DIC(0)="LX",X=SDWLSC,DIC="^SDWL(409.32," D FILE^DICN + S DA=$O(^SDWL(409.32,"B",SDWLSC,"")) + K DIC,DIC(0) + S SDWLSCN=$P($G(^SDWL(409.32,DA,0)),U,1) D + .I $D(^SDWL(409.3,"C",SDWLSCN)) D + ..S SDWLN="",SDWLCNT=0 F S SDWLN=$O(^SDWL(409.3,"C",SDWLSCN,SDWLN)) Q:SDWLN="" D + ...S X=$G(^SDWL(409.3,SDWLN,0)) I '$D(^SDWL(409.3,SDWLN,"DIS")) S SDWLCNT=SDWLCNT+1,^TMP("SDWLPE",$J,"DIS",SDWLN,SDWLCNT)=X,SDWLSTOP=1 + W ! I SDWLSTOP W "This Clinic has Patients on the Wait List and can not be inactivated." Q + S DR="1",DIE="^SDWL(409.32," D ^DIE I X S DR="2////^S X=DUZ" D ^DIE + S DR="3",DIE="^SDWL(409.32," D ^DIE I X S DR="4////^S X=DUZ" D ^DIE + K DR,DIE,DIC,Y,X,SDWLY,DIC(0),DO,DA,DI,DIW,SDWLX,SDWLSCN,SDWLF + Q +SWT ;SWITCH FOR INACTIVIATION OF PARAMETER FILE + Q +HD ;HEADER + W:$D(IOF) @IOF W !!,?80-$L("Wait List Parameter Enter/Edit")\2,"Wait List Parameter Enter/Edit",! + W !,?80-$L("------------------------------")\2,"------------------------------",! +END K SDWLSTOP,DIR,DIC,DR,DIK,SDWLX,SDWLSCN,SDWLF,SDWLY,SDWLSC,SDWLN,SDWLCNT,SDWLDSS,DUOUT,X,Y + Q Index: WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLQSR.m =================================================================== --- WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLQSR.m (revision 613) +++ WorldVistAEHR/trunk/r/SCHEDULING-SD-SC/SDWLQSR.m (revision 623) @@ -1,67 +1,53 @@ -SDWLQSR ;BPOI/TEH - WAIT LIST STAT REPORT;06/12/02 - ;;5.3;scheduling;**263,425,448,524**;08/13/93;Build 29 - ; - ; - ; - ; - ; -EN N ZCODE,ZTDESC,ZTDTH,ZTIO,ZTQUEDED,ZTREQ,ZTRTN,ZTSAVE,ZTSK,POP - K ^TMP("SDWLQSR",$J) - D HD -1 D INS G END:$D(DUOUT) -2 D DATE G END:$D(DUOUT) -3 D EXCL G END:$D(DUOUT) - D QUE G END:$D(DUOUT) - Q -INS ;Get Institution - S SDWLERR=0,SDWLPROM="Select Institution ALL // ",SDWLINST="" -IN W ! S DIC(0)="QEMA",DIC("A")=SDWLPROM,DIC=4,DIC("S")="I $D(^SDWL(409.32,""C"",+Y))!$D(^SDWL(409.31,""E"",+Y))!$D(^SCTM(404.51,""AINST"",+Y))" D ^DIC I Y<0,'SDWLERR Q:$D(DUOUT) S Y="ALL" - G IN2:Y<0 Q:$D(DUOUT) - I Y<0 S SDWLINST=$S(Y="ALL":"ALL",Y="":"ALL",Y="all":"ALL",Y="All":"ALL",Y["A":"ALL",Y["a":"ALL") - I Y="All"!(Y="")!(Y="all")!(Y="ALL") S SDWLINST="ALL",^TMP("SDWLQSR",$J,"INS")="ALL" G IN3 - S SDWLINST=SDWLINST_Y_";",SDWLPROM="Another Institution: ",SDWLERR=1 G IN -IN2 S ^TMP("SDWLQSR",$J,"INS")=SDWLINST -IN3 Q -DATE ;Date range selection - K X,Y,%DT - S SDWLERR=0 W ! S %DT="AE",%DT("A")="Start Date: " D ^%DT - I X["^" S DUOUT=1 Q - I Y<0 S DUOUT=1 Q - S SDWLBDT=Y - Q:$D(DUOUT) - S %DT("A")="End Date: " D ^%DT G DATE:Y<1 S SDWLEDT=Y K %DT(0),%DT("A") - G DATE:$D(DUOUT) - I SDWLEDT(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 added Quit for early exit - .I $$S^%ZTLOAD S DUOUT="" Q - .W !!,"INSTITUTION: ",SDWLINS,! K ^XTMP("SDWLRSR") - .S SDWLTY="" F S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY="" D Q:POP ;SD*5.3*412 added Quit for early exit - ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) - ..S SDWLSCN="" F S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN="" D Q:POP ;SD*5.3*412 added Quit for early exit - ...S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0 ;SD*5.3*415 - ...S SDWLSCNM="" F S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM="" D Q:POP D T1 Q:POP ;SD*5.3*412 added Quit - ....S SDWLPRI="" F S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI="" D Q:POP ;SD*5.3*412 added Quit - .....S SDWLFLG=0 - .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) I SDWLEXCL,SDWLPR S SDWLFLG=1 - .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) I 'SDWLFLG,SDWLEXCL,SDWLCL S SDWLFLG=1 - .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) I 'SDWLFLG,SDWLEXCL,SDWLD S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) I 'SDWLFLG,SDWLEXCL,SDWLNC S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) I 'SDWLFLG,SDWLEXCL,SDWLSA S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) I 'SDWLFLG,SDWLEXCL,SDWLCC S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) I 'SDWLFLG,SDWLEXCL,SDWLNN S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) I 'SDWLFLG,SDWLEXCL,SDWLER S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR")) I 'SDWLFLG,SDWLEXCL,SDWLTR S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) I 'SDWLFLG,SDWLEXCL,SDWLAD S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) I 'SDWLFLG,SDWLEXCL,SDWLRR S SDWLFLG=1 ;SD*5.3*415 - .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) I 'SDWLFLG,SDWLEXCL,SDWLNR S SDWLFLG=1 ;W ?72,$J(SDWLNR,3) - .....I 'SDWLEXCL,'SDWLFLG S SDWLFG=1 - .....I SDWLEXCL,'SDWLFLG Q - .....I '$D(^XTMP("SDWLRSR",$J,SDWLTNM)) W !,$E(SDWLTNM,1,15) S ^XTMP("SDWLRSR",$J,SDWLTNM)="" - .....W !?2,$E(SDWLSCNM_" "_$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:""),1,17) - .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR W ?21,$J(SDWLPR,3) - .....S T2=T2+SDWLCL,TT2=TT2+SDWLCL W ?26,$J(SDWLCL,3) - .....S T3=T3+SDWLD,TT3=TT3+SDWLD W ?31,$J(SDWLD,3) - .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC W ?36,$J(SDWLNC,3) - .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA W ?41,$J(SDWLSA,3) - .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC W ?46,$J(SDWLCC,3) - .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN W ?51,$J(SDWLNN,3) - .....S T8=T8+SDWLER,TT8=TT8+SDWLER W ?56,$J(SDWLER,3) - .....S T9=T9+SDWLTR,TT9=TT9+SDWLTR W ?61,$J(SDWLTR,3) ;SD*5.3*415 - .....S T10=T10+SDWLAD,TT10=TT10+SDWLAD W ?66,$J(SDWLAD,3) ;SD*5.3*415 - .....S T11=T11+SDWLRR,TT11=TT11+SDWLRR W ?71,$J(SDWLRR,3) ;SD*5.3*415 - .....S T12=T12+SDWLNR,TT12=TT12+SDWLNR W ?76,$J(SDWLNR,3) ;SD*5.3*415 - .....I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 - Q -SCR S DIR(0)="E" D ^DIR S:X="^" POP=1 ;SD*5.3*412 - Q -T1 ; - I 'SDWLFLG,SDWLEXCL Q - W !?20,"---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ---- ----" ;SD*5.3*415 - W !,"Sub-Totals:" - ;write sub-totals - W ?21,$J(T1,3),?26,$J(T2,3),?31,$J(T3,3),?36,$J(T4,3),?41,$J(T5,3),?46,$J(T6,3),?51,$J(T7,3),?56,$J(T8,3),?61,$J(T9,3),?66,$J(T10,3),?71,$J(T11,3),?76,$J(T12,3),! ;SD*5.3*415 - S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12)=0 ;SD*5.3*415 - I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 - Q -T2 W !,"Institution Totals:" - W ?21,$J(TT1,3),?26,$J(TT2,3),?31,$J(TT3,3),?36,$J(TT4,3),?41,$J(TT5,3),?46,$J(TT6,3),?51,$J(TT7,3),?56,$J(TT8,3),?61,$J(TT9,3),?66,$J(TT10,3),?71,$J(TT11,3),?76,$J(TT12,3),! ;SD*5.3*415 - S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12)=0 ;SD*5.3*415 - I $Y>(IOSL-5) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 - Q -HD W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG - W !,?80-$L("STARTED Date: ")\2,"STARTED Date: " S Y=$P(SDWLDATE,U,1) D DD^%DT W Y - W !,?80-$L("FINISHED Date: ")\2,"FINISHED Date: " S Y=$P(SDWLDATE,U,2) D DD^%DT W Y - Q -HD1 ; - W !,?20,"PREV" - W ?65,"#" - W ?75,"# NOT" - W !,"WAIT LIST TYPE" - W ?20,"REMN",?25,"CLSD",?31,"DTH",?37,"NC",?42,"SA",?47,"CC",?52,"NN",?57,"ER",?61,"TR",?65,"ADD",?70,"REMN",?75,"REMVD",! ;SD*5.3*415 - Q -END D EN^SDWLKIL - K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I - K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE ;SD*5.3*415 - K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN ;SD*5.3*415 - K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR ;SD*5.3*415 - Q +SDWLRSR ;;IOFO BAY PINES/TEH/WAIT LIST STAT REPORT ; 01 Oct 2002 4:42 PM ; Compiled December 21, 2006 15:32:50 + ;;5.3;scheduling;**263,273,399,412,425,415,446**;AUG 13 1993;Build 77 + ; + ; Removed Sort logic as routine exceeded SACC maximum size of 10000 + ; New routine SDWLRSRS was created to perform the Sort functionality + ; + ; +EN ; + D INIT G END:$D(DUOUT) ;SD*5.3*415 + D SORT^SDWLRSRS(SDWLBD,SDWLED,SDWLINS,.SDWL) ; SD*5.3*415 new routine to perform sort + D:'$$S^%ZTLOAD PRT ;SD*5.3*415 + G END +INIT ; + I $D(CT) S SDWLCT2=CT + I $D(DATE) S SDWLDATE=DATE + I $D(INS) S SDWLINS=INS + I $D(ZTSAVE) D + .S SDWLCT=$G(ZTSAVE("CT")),SDWLDATE=$G(ZTSAVE("DATE")),SDWLINS=$G(ZTSAVE("INS")) + I SDWLINS'="ALL" F I=1:1 S SDWL=$P(SDWLINS,";",I) Q:SDWL="" S SDWL("INS",+SDWL)="" + S SDWLBD=$P(SDWLDATE,U,1),SDWLED=$P(SDWLDATE,U,2),SDWLPG=0 + D NOW^%DTC S Y=% D DD^%DT S SDWLDTP=Y + N POP S POP=0 ;SD*5.3*412 + Q +PRT ;PRINT REPORT + S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0 ;SD*5.3*446 + S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLPG)=0 D HD,HD1 ;SD*5.3*415,446 + I '$D(^TMP("SDWLRSR1")) W !!,"No Wait List Data to Report" Q + S SDWLINS="" F S SDWLINS=$O(^TMP("SDWLRSR1",$J,SDWLINS)) Q:SDWLINS="" D Q:POP D T2 Q:POP W !,"________________" I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412 added Quit for early exit; 446 + .I $$S^%ZTLOAD S DUOUT="" Q + .W !!,"INSTITUTION: ",SDWLINS,! + .S SDWLTY="" F S SDWLTY=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY)) Q:SDWLTY="" D Q:POP ;SD*5.3*412 added Quit for early exit + ..S SDWLTNM=$$EXTERNAL^DILFD(409.3,4,,SDWLTY) W !,$E(SDWLTNM,1,15) + ..S SDWLSCN="" F S SDWLSCN=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN)) Q:SDWLSCN="" D Q:POP ;SD*5.3*412 added Quit for early exit + ...S SDWLSCNM="" F S SDWLSCNM=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM)) Q:SDWLSCNM="" D Q:POP D T1 Q:POP ;SD*5.3*412 added Quit + ....S SDWLPRI="" F S SDWLPRI=$O(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI)) Q:SDWLPRI="" D Q:POP ;SD*5.3*412 added Quit + .....N SDWLCLO ; SD*5.3*446 + .....W !,?2,$E(SDWLSCNM,1,10)," ",$S(SDWLPRI="A":"ASAP",SDWLPRI="F":"FUTURE",1:"") + .....S SDWLPR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"PR")) W ?20,SDWLPR + .....S SDWLCLO=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"CL")) W ?27,SDWLCLO ;SD*5.3*446 + .....S SDWLD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLD")) W ?34,SDWLD ;SD*5.3*415,446 + .....S SDWLNC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNC")) W ?41,SDWLNC ;SD*5.3*415,446 + .....S SDWLSA=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLSA")) W ?48,SDWLSA ;SD*5.3*415,446 + .....S SDWLCC=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCC")) W ?55,SDWLCC ;SD*5.3*415,446 + .....S SDWLNN=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLNN")) W ?62,SDWLNN ;SD*5.3*415,446 + .....S SDWLER=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLER")) W ?69,SDWLER ;SD*5.3*415,446 + .....S SDWLCL=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLCL")) W ?76,SDWLCL ;SD*5.3*415,446 + .....S SDWLTR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"SDWLTR")) W ?83,SDWLTR ;SD*5.3*415,446 + .....S SDWLAD=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"AD")) W ?90,SDWLAD ;SD*5.3*415,446 + .....S SDWLRR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"RR")) W ?97,SDWLRR ;SD*5.3*415,446 + .....S SDWLNR=+$G(^TMP("SDWLRSR1",$J,SDWLINS,SDWLTY,SDWLSCN,SDWLSCNM,SDWLPRI,"NR")) W ?104,SDWLNR ;SD*5.3*446 + .....S T1=T1+SDWLPR,TT1=TT1+SDWLPR + .....S T2=T2+SDWLCLO,TT2=TT2+SDWLCLO ;SD*5.3*446 + .....S T3=T3+SDWLD,TT3=TT3+SDWLD + .....S T4=T4+SDWLNC,TT4=TT4+SDWLNC + .....S T5=T5+SDWLSA,TT5=TT5+SDWLSA + .....S T6=T6+SDWLCC,TT6=TT6+SDWLCC + .....S T7=T7+SDWLNN,TT7=TT7+SDWLNN + .....S T8=T8+SDWLER,TT8=TT8+SDWLER + .....S T9=T9+SDWLCL,TT9=TT9+SDWLCL ;SD*5.3*446 + .....S T10=T10+SDWLTR,TT10=TT10+SDWLTR ;SD*5.3*446 + .....S T11=T11+SDWLAD,TT11=TT11+SDWLAD ;SD*5.3*446 + .....S T12=T12+SDWLRR,TT12=TT12+SDWLRR ;SD*5.3*446 + .....S T13=T13+SDWLNR,TT13=TT13+SDWLNR ;SD*5.3*446 + .....I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412,446 + Q +SCR S DIR(0)="E" D ^DIR S:X="^" POP=1 ;SD*5.3*412 + Q +T1 ; + ;write sub-totals + W !?20,"------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------ ------" ;SD*5.3*446 + W !,"Sub-Totals:",?20,T1,?27,T2,?34,T3,?41,T4,?48,T5,?55,T6,?62,T7,?69,T8,?76,T9,?83,T10,?90,T11,?97,T12,?104,T13 ;SD*5.3*446 + S (T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13)=0 ;SD*5.3*415,446 + I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412,446 + Q +T2 W !,"Institution Totals:" + W ?20,TT1,?27,TT2,?34,TT3,?41,TT4,?48,TT5,?55,TT6,?62,TT7,?69,TT8,?76,TT9,?83,TT10,?90,TT11,?97,TT12,?104,TT13,! ;SD*5.3*446 + S (TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13)=0 ;SD*5.3*415,446 + I $Y>(IOSL-8) D:$D(SDWLSPT) SCR Q:POP D HD,HD1 ;SD*5.3*412,446 + Q +HD W:$D(IOF) @IOF S SDWLPG=SDWLPG+1 W !!,SDWLDTP,?80-$L("Wait List (Sch/PCMM) Stat Report")\2,"Wait List (Sch/PCMM) Stat Report",?65,"Page: ",SDWLPG + W !,?80-$L("STARTED Date: ")\2,"STARTED Date: " S Y=$P(SDWLDATE,U,1) D DD^%DT W Y + W !,?80-$L("FINISHED Date: ")\2,"FINISHED Date: " S Y=$P(SDWLDATE,U,2) D DD^%DT W Y + Q +HD1 ; + W !,?20,"PREV",?90,"#",?97,"#",?104,"# NOT" ;SD*5.3*415,446 + W !,"WAIT LIST TYPE",?20,"REMN",?27,"CLSD",?34,"DTH",?41,"NC",?48,"SA",?55,"CC",?62,"NN",?69,"ER",?76,"CL",?83,"TR",?90,"ADD",?97,"REMN",?104,"REMVD" ;SD*5.3*446 + Q +END D EN^SDWLKIL + K ^TMP("SDWLRSR1",$J),^TMP("SDWLRSR2",$J),SDWLY1,SDWLX1,SDWLRDT,CT,I + K T1,T2,T3,T4,T5,T6,T7,T8,T9,T10,T11,T12,T13,SDWLAD,SDWLBD,SDWLCC,SDWLCT,SDWLDFDT,SDWLDP,SDWLED,SDWLER,SDWLERR,SDWLFLD,X1,X2,DATE ;SD*5.3*415,446 + K TT1,TT2,TT3,TT4,TT5,TT6,TT7,TT8,TT9,TT10,TT11,TT12,TT13,SDWLINSN,SDWLINST,SDWLNC,SDWLNN,SDWLNR,SDWLOFDT,SDWLOK1,SDWLOK2,SDWLTYPN ;SD*5.3*415,446 + K SDWLOK3,SDWLPR,SDWLPR,SDWLPROM,SDWLRE,SDWLRFDT,SDWLRR,SDWLSA,SDWLSCN,SDWLSCNM,SDWLTASK,SDWLTK,SDWLTNM,SDWLTYNM,SDWLTYP,X4,SDWLTR,SDWLCL ;SD*5.3*415,446 + Q