| 1 | SCMCCV ;ALB/REW - PCMM Conversion of Patient File Fields ; 1 Feb 1996
|
|---|
| 2 | ;;5.3;Scheduling;**41**;AUG 13, 1993
|
|---|
| 3 | EN ;
|
|---|
| 4 | ; Variables:
|
|---|
| 5 | ; SCASSIGN: 1=Make Patient Assignments if unambiguous (0=No,default)
|
|---|
| 6 | ; SCDT: Date to make assignments (Default=DT)
|
|---|
| 7 | ; SCYESTM: 1=Make Pt Tm as well as Pt Posit Assmnts,default(0=No)
|
|---|
| 8 | ; SCNOPRPT 1=Don't print patient-detail lines
|
|---|
| 9 | ;
|
|---|
| 10 | N SCOK,DFN,SCPCNODE,SCLIST,SCTMPLST,SCHISTAR,SCASSIGN,SCYESTM,SCTM,Y,SCSTOP,SCPAGE,SCNOPRPT,SCTEAMAR,SCNOW,SCSUB
|
|---|
| 11 | N SCLSEQ,SCN,SCESEQ,SCPARM,SCP,SCBEGIN,SCEND,SCINCL,SCDTS
|
|---|
| 12 | IF '$$OKASK D MESS("Search aborted","!?5") G QTEN
|
|---|
| 13 | IF '$D(IO("Q")) D
|
|---|
| 14 | .U IO
|
|---|
| 15 | .D REP
|
|---|
| 16 | .D ^%ZISC
|
|---|
| 17 | ELSE D
|
|---|
| 18 | .F X="SCASSIGN","SCYESTM","SCDT","SCNOPRPT" S ZTSAVE(X)=""
|
|---|
| 19 | .S Y=$$QUE("SC Patient-Team/Practitioner"_$S('SCASSIGN:"Report Only",1:"Report and Assignment"),"REP^SCMCCV")
|
|---|
| 20 | QTEN Q
|
|---|
| 21 | ;
|
|---|
| 22 | OKASK() ;
|
|---|
| 23 | N SCOK,DIR
|
|---|
| 24 | ;do you want to assign or just get a report?
|
|---|
| 25 | S DIR(0)="Y"
|
|---|
| 26 | S DIR("B")="NO"
|
|---|
| 27 | S DIR("A")="Do you want to assign patients right now?"
|
|---|
| 28 | S DIR("A",1)=""
|
|---|
| 29 | S DIR("A",2)=""
|
|---|
| 30 | S DIR("A",3)=" YES = Assign Patients to Teams and Team Positions"
|
|---|
| 31 | S DIR("A",4)=" NO = Just print report to see how things would be"
|
|---|
| 32 | D ^DIR
|
|---|
| 33 | IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S SCOK=0 G QTASK
|
|---|
| 34 | S SCASSIGN=Y
|
|---|
| 35 | ;do you want to omit printing patients?
|
|---|
| 36 | S DIR(0)="Y"
|
|---|
| 37 | S DIR("B")="YES"
|
|---|
| 38 | S DIR("A")="Do you want to omit printing patients?"
|
|---|
| 39 | S DIR("A",1)=""
|
|---|
| 40 | S DIR("A",2)=""
|
|---|
| 41 | S DIR("A",3)=" NO = Print detail line for each patient that is assignable"
|
|---|
| 42 | S DIR("A",4)=" YES = Just print Team & Practitioner information"
|
|---|
| 43 | D ^DIR
|
|---|
| 44 | IF $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S SCOK=0 G QTASK
|
|---|
| 45 | S SCNOPRPT=Y
|
|---|
| 46 | IF '$D(SCASSIGN) S SCASSIGN=0
|
|---|
| 47 | IF '$D(SCDT) S SCDT=DT
|
|---|
| 48 | IF '$D(SCYESTM) S SCYESTM=1
|
|---|
| 49 | S SCOK=$$GETDEV
|
|---|
| 50 | QTASK Q SCOK
|
|---|
| 51 | ;
|
|---|
| 52 | REP ;non-interactive portion
|
|---|
| 53 | Q:$$FIRST^SCMCRU ;check for task end
|
|---|
| 54 | IF '$$OKINIT() G QTEN
|
|---|
| 55 | D MESS(" ..Ok")
|
|---|
| 56 | IF '$$OKBUILD G QRP
|
|---|
| 57 | D MESS(" ..Ok")
|
|---|
| 58 | IF '$$OKREPORT G QRP
|
|---|
| 59 | D MESS(" ..Ok")
|
|---|
| 60 | IF '$$OKCLEAN G QRP
|
|---|
| 61 | D MESS(" ..Ok")
|
|---|
| 62 | QRP Q
|
|---|
| 63 | ;
|
|---|
| 64 | OKINIT() ;
|
|---|
| 65 | N SCOK
|
|---|
| 66 | S SCOK=1
|
|---|
| 67 | D MESS(">>> Checking Programmer Variables:","!,?5")
|
|---|
| 68 | IF +$G(DUZ)'>0!($G(U)'="^")!('$D(DT)) D Q 0
|
|---|
| 69 | . S XPDABORT=1
|
|---|
| 70 | . D MESS("You must first initialize Programmer Environment by running ^XUP")
|
|---|
| 71 | . S SCOK=0
|
|---|
| 72 | S SCLIST="SCTMPLST"
|
|---|
| 73 | D INIT^SCAPMCU1(.SCOK)
|
|---|
| 74 | D NOW^%DTC
|
|---|
| 75 | S SCNOW=%
|
|---|
| 76 | S SCHISTAR(.05)=1 ;pc practitioner
|
|---|
| 77 | S SCHISTAR(.06)=DUZ ;user entering
|
|---|
| 78 | S SCHISTAR(.07)=SCNOW ;date entered
|
|---|
| 79 | S SCTEAMAR(.08)=1 ;pc team
|
|---|
| 80 | S SCTEAMAR(.11)=DUZ ;user
|
|---|
| 81 | S SCTEAMAR(.12)=SCNOW ;date enter=now
|
|---|
| 82 | Q SCOK
|
|---|
| 83 | ;
|
|---|
| 84 | OKBUILD() ;
|
|---|
| 85 | N SCOK
|
|---|
| 86 | S SCOK=1
|
|---|
| 87 | D MESS(">>> Looping through PC Nodes of PATIENT File","!,?5")
|
|---|
| 88 | S DFN=0
|
|---|
| 89 | F S DFN=$O(^DPT(DFN)) Q:'DFN S SCPCNODE=$G(^DPT(DFN,"PC")) IF SCPCNODE]"" D D:'(DFN#100) MESS(".")
|
|---|
| 90 | .S ^TMP("SCMC",$J,"TMPRPT",+$P(SCPCNODE,U,2),+$P(SCPCNODE,U,1),DFN)=""
|
|---|
| 91 | Q SCOK
|
|---|
| 92 | ;
|
|---|
| 93 | OKREPORT() ;
|
|---|
| 94 | N SCOK,SCTM,SCPR,SCTMNODE
|
|---|
| 95 | S SCOK=1
|
|---|
| 96 | D MESS(">>> Producing PATIENT File PC Report","!?5")
|
|---|
| 97 | D MESS(" Checking Team/Practitioner Assignments:","!?10")
|
|---|
| 98 | S SCTM=0
|
|---|
| 99 | F S SCTM=$O(^TMP("SCMC",$J,"TMPRPT",SCTM)) Q:'SCTM!$G(SCSTOP) D
|
|---|
| 100 | .S SCTMNODE=$G(^SCTM(404.51,SCTM,0))
|
|---|
| 101 | .D MESS(">>>Team: "_$$DISPTM(SCTM),"!!?10")
|
|---|
| 102 | .IF '$$OKTEAM(SCTM,SCDT) D
|
|---|
| 103 | ..S SCOK=0
|
|---|
| 104 | ..;D MESS("Problem(s) with Practitioner Assignments","!?15")
|
|---|
| 105 | Q SCOK
|
|---|
| 106 | ;
|
|---|
| 107 | OKTEAM(SCTM,SCDT) ;return 1 if exactly 1 posit for each team assignment
|
|---|
| 108 | ;needs 'tmp('scmc',$j,'tmpr' array defined
|
|---|
| 109 | ;return count of positions pract is assigned to to team
|
|---|
| 110 | N SCOK,SC200,SCTMND,SCFLD,SCF
|
|---|
| 111 | S SCOK=1
|
|---|
| 112 | S SCTMND=$G(^SCTM(404.51,+$G(SCTM),0))
|
|---|
| 113 | F SCFLD=3,6,7 IF '$P(SCTMND,U,SCFLD) D ;check required fields
|
|---|
| 114 | .S SCOK=0
|
|---|
| 115 | .S SCF=$$DDNAME^SCMCRU(404.51,(SCFLD*.01))
|
|---|
| 116 | .D MESS(SCF_" (#"_(SCFLD*.01)_") of Team required. Enter via PCMM ","!?20")
|
|---|
| 117 | G:'SCOK QTOKTM
|
|---|
| 118 | S SCOK=$$ACTTM^SCMCTMU(SCTM,SCDT)
|
|---|
| 119 | IF 'SCOK D G QTOKTM
|
|---|
| 120 | .N SCX
|
|---|
| 121 | .S SCX=$D(^SCTM(404.58,SCTM,"AIDT",SCTM))
|
|---|
| 122 | .D:'SCX MESS(" Never activated - Edit via PCMM")
|
|---|
| 123 | .D:SCX MESS(" Not active on "_SCDT)
|
|---|
| 124 | IF SCOK<0 D G QTOKTM
|
|---|
| 125 | .D MESS(" Error in setup")
|
|---|
| 126 | IF $D(^TMP("SCMC",$J,"TMPRPT",SCTM,0)) D
|
|---|
| 127 | .D MESS("Team Assignment Only","!?15")
|
|---|
| 128 | .D:'SCNOPRPT MESS("Patients to be assigned to this team:","!?20")
|
|---|
| 129 | .S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,0,DFN)) Q:'DFN D
|
|---|
| 130 | ..D MESS($$DISPPT(DFN),"!?25")
|
|---|
| 131 | ..S SCX=$$NMPCTM^SCAPMCU2(DFN,SCDT,1)
|
|---|
| 132 | ..D:SCX&(+SCX=SCTM)&('SCNOPRPT) MESS("Already assigned","!?27")
|
|---|
| 133 | ..D:SCX&(+SCX'=SCTM)&('SCNOPRPT) MESS("Previously assigned to "_$P(SCX,U,2),"!?27")
|
|---|
| 134 | ..Q:SCX
|
|---|
| 135 | ..D:$G(SCASSIGN) PCUPDTM(DFN)
|
|---|
| 136 | .D:$G(SCASSIGN) MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
|
|---|
| 137 | .F SCSUB="NEWTM","BADTM" K ^TMP("SCMC",$J,SCSUB,SCTM)
|
|---|
| 138 | S SC200=0
|
|---|
| 139 | F S SC200=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200)) Q:'SC200 D
|
|---|
| 140 | .N SCTMPLST,SCCNT,SCTP,SCX,DFN
|
|---|
| 141 | .D MESS("Practitioner: "_$$DISP200(SC200),"!?15")
|
|---|
| 142 | .IF '$D(^VA(200,SC200,0)) D
|
|---|
| 143 | ..S SCOK=0
|
|---|
| 144 | ..D MESS("Bad Practitioner Assignment"_$S(SCNOPRPT:"",1:" for the following patient(s):"),"!?15")
|
|---|
| 145 | ..S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200,DFN)) Q:'DFN D
|
|---|
| 146 | ...D MESS($$DISPPT(DFN),"!?25")
|
|---|
| 147 | .ELSE D
|
|---|
| 148 | .S:'$$TPPR^SCAPMC(SC200,"SCDTS",,,"SCTMPLST($J)",.SCERR) SCOK=0
|
|---|
| 149 | .S SCXTP=0 F SCCNT=0:1 S SCXTP=$O(SCTMPLST($J,"SCTP",SCTM,SCXTP)) Q:'SCXTP S SCTP=SCXTP D MESS("Position: "_$$DISPTP(SCTP),"!?17")
|
|---|
| 150 | .;if no team-position assignments for pract
|
|---|
| 151 | .IF 'SCCNT D
|
|---|
| 152 | ..S SCOK=0
|
|---|
| 153 | ..D MESS("is assigned to "_SCCNT_" positions on team","!?20")
|
|---|
| 154 | ..D MESS("you need to assign him/her to a position on the team","!?20")
|
|---|
| 155 | ..S ^TMP("SCMC",$J,"NO_TP",SCTM,SC200)=""
|
|---|
| 156 | .;if exactly one practitioner assignment to team
|
|---|
| 157 | .IF SCCNT=1 D
|
|---|
| 158 | ..D:'SCNOPRPT MESS("Patients to be assigned to this position:","!?20")
|
|---|
| 159 | ..S DFN=0 F S DFN=$O(^TMP("SCMC",$J,"TMPRPT",SCTM,SC200,DFN)) Q:'DFN D
|
|---|
| 160 | ...D MESS($$DISPPT(DFN),"!?25")
|
|---|
| 161 | ...S SCX=$$NMPCTP^SCAPMCU2(DFN,SCDT,1)
|
|---|
| 162 | ...D:SCX&(+SCX=SCTP)&('SCNOPRPT) MESS("Already assigned","!?27")
|
|---|
| 163 | ...D:SCX&(+SCX'=SCTP)&('SCNOPRPT) MESS("Previously assigned to "_$P(SCX,U,2),"!?27")
|
|---|
| 164 | ...Q:SCX
|
|---|
| 165 | ...D:$G(SCASSIGN) PCUPD(DFN)
|
|---|
| 166 | ..D:$G(SCASSIGN) MAILLST^SCMCTPM(SCTP,"SCHISTAR",SCDT,"^TMP(""SCMC"",$J,""NEWTP"",SCTP)","^TMP(""SCMC"",$J,""OLDTP"",SCTP)","^TMP(""SCMC"",$J,""BADTP"",SCTP)")
|
|---|
| 167 | ..D:$G(SCASSIGN) MAILLST^SCMCTMM(SCTM,"SCTEAMAR",SCDT,"^TMP(""SCMC"",$J,""NEWTM"",SCTM)")
|
|---|
| 168 | ..F SCSUB="NEWTP","OLDTP","BADTP" K ^TMP("SCMC",$J,SCSUB,SCTP)
|
|---|
| 169 | ..K ^TMP("SCMC",$J,"NEWTM",SCTM)
|
|---|
| 170 | .;if multiple positin assignments for team for pract
|
|---|
| 171 | .IF SCCNT>1 D
|
|---|
| 172 | ..S SCOK=0
|
|---|
| 173 | ..D MESS("Practitioner is assigned to "_SCCNT_" positions on team","!?20")
|
|---|
| 174 | ..D MESS("because there is more than one position for this team","!?20")
|
|---|
| 175 | ..D MESS("and practitioner, there will be no patient assignments","!?20")
|
|---|
| 176 | ..S SCTP=0 F S SCTP=$O(SCTMPLST($J,SCTM,SCTP)) Q:'SCTP S ^TMP("SCMC",$J,"MULT_TP",SCTM,SC200,SCTP)=""
|
|---|
| 177 | .IF SCCNT=1 S ^TMP("SCMC",$J,"ONE_TP",SCTM,SC200,SCTP)=""
|
|---|
| 178 | QTOKTM Q SCOK
|
|---|
| 179 | ;
|
|---|
| 180 | PCUPD(DFN) ;
|
|---|
| 181 | N SCX,SCNOMAIL
|
|---|
| 182 | S SCNOMAIL=1
|
|---|
| 183 | ;This is NOT a stand-alone procedure
|
|---|
| 184 | S SCX=$$ACPTTP^SCAPMC(DFN,SCTP,"SCHISTAR",SCDT,.SCERR,SCYESTM)
|
|---|
| 185 | IF SCX D
|
|---|
| 186 | .D MESS("File #404.43 ien = "_+SCX,"!?30")
|
|---|
| 187 | .IF $P(SCX,U,2) D
|
|---|
| 188 | ..D MESS(" New Entry")
|
|---|
| 189 | ..S ^TMP("SCMC",$J,"NEWTP",SCTP,DFN)=""
|
|---|
| 190 | ..IF $P(SCX,U,4) D
|
|---|
| 191 | ...D MESS(" Team Assignment Made. IEN="_$P(SCX,U,3),"!?30")
|
|---|
| 192 | ...S ^TMP("SCMC",$J,"NEWTM",SCTM,DFN)=""
|
|---|
| 193 | .ELSE D
|
|---|
| 194 | ..D MESS(" Already Assigned")
|
|---|
| 195 | ..S ^TMP("SCMC",$J,"OLDTP",SCTP,DFN)=""
|
|---|
| 196 | ELSE D
|
|---|
| 197 | .D MESS(" - NOT saved")
|
|---|
| 198 | .S ^TMP("SCMC",$J,"BADTP",+$G(SCTP),DFN)=""
|
|---|
| 199 | .D:('$P(SCX,U,2))&('$P(SCX,U,4))&('$P(SCX,U,3)) MESS("No Patient Team Assignment","!?30")
|
|---|
| 200 | Q
|
|---|
| 201 | ;
|
|---|
| 202 | PCUPDTM(DFN) ;
|
|---|
| 203 | N SCX,SCNOMAIL
|
|---|
| 204 | S SCNOMAIL=1
|
|---|
| 205 | ;This is NOT a stand-alone procedure
|
|---|
| 206 | S SCX=$$ACPTTM^SCAPMC(DFN,SCTM,"SCTEAMAR",SCDT,.SCERR)
|
|---|
| 207 | IF SCX D
|
|---|
| 208 | .D MESS("File #404.42 ien = "_+SCX,"!?30")
|
|---|
| 209 | .IF $P(SCX,U,2) D
|
|---|
| 210 | ..D MESS(" New Entry")
|
|---|
| 211 | ..S ^TMP("SCMC",$J,"NEWTM",SCTM,DFN)=""
|
|---|
| 212 | ELSE D
|
|---|
| 213 | .D MESS(" - NOT saved")
|
|---|
| 214 | .S ^TMP("SCMC",$J,"BADTM",+$G(SCTM),DFN)=""
|
|---|
| 215 | Q
|
|---|
| 216 | ;
|
|---|
| 217 | OKCLEAN() ;
|
|---|
| 218 | D MESS(">>> Cleaning up ^TMP(""SCMC"" global","!?5")
|
|---|
| 219 | N SCOK
|
|---|
| 220 | S SCOK=1
|
|---|
| 221 | ;K ^TMP("SCMC",$J)
|
|---|
| 222 | Q SCOK
|
|---|
| 223 | ;
|
|---|
| 224 | DISP200(SC200) ;
|
|---|
| 225 | Q $P($G(^VA(200,SC200,0)),U,1)_" [#"_SC200_"]"
|
|---|
| 226 | ;
|
|---|
| 227 | DISPTP(SCTP) ;
|
|---|
| 228 | Q $P($G(^SCTM(404.57,SCTP,0)),U,1)_" [#"_SCTP_"]"
|
|---|
| 229 | ;
|
|---|
| 230 | DISPTM(SCTM) ;
|
|---|
| 231 | Q $P($G(^SCTM(404.51,SCTM,0)),U,1)_" [#"_SCTM_"]"
|
|---|
| 232 | ;
|
|---|
| 233 | DISPPT(DFN) ;
|
|---|
| 234 | Q $S(SCNOPRPT:"",1:$E($P($G(^DPT(DFN,0)),U,1),1,21)_" [SSN#:"_$P($G(^DPT(DFN,0)),U,9)_"]")
|
|---|
| 235 | ;
|
|---|
| 236 | MESS(TEXT,FORMAT) ;
|
|---|
| 237 | Q:$G(SCSTOP)!($G(TEXT)="")
|
|---|
| 238 | S FORMAT=$G(FORMAT,"?5")
|
|---|
| 239 | D OUT^SCMCRU(TEXT,FORMAT)
|
|---|
| 240 | Q
|
|---|
| 241 | ;
|
|---|
| 242 | GETDEV() ;
|
|---|
| 243 | N SCOK
|
|---|
| 244 | S SCOK=0
|
|---|
| 245 | S %ZIS="PMQ" D ^%ZIS G:POP QTGDV
|
|---|
| 246 | S SCOK=1
|
|---|
| 247 | QTGDV Q (SCOK)
|
|---|
| 248 | ;
|
|---|
| 249 | QUE(NAME,START) ;
|
|---|
| 250 | ; Needed: ZTSAVE array
|
|---|
| 251 | ; NAME = description
|
|---|
| 252 | ; START = starting point of routine
|
|---|
| 253 | S ZTDESC=NAME,ZTRTN=START
|
|---|
| 254 | D ^%ZTLOAD W:$D(ZTSK) !,"TASK #",ZTSK
|
|---|
| 255 | D HOME^%ZIS K IO("Q")
|
|---|
| 256 | Q ZTSK
|
|---|
