- 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,532,504,581**;AUG 13, 1993;Build 16
- 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
- .;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)<STDT S NEW=0
- .E S NEW=1
- .N TYDT
- .I NEW N STDT S %DT="",X="T-11M" D ^%DT S STDT=+Y D
- ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- .I 'NEW N STDT S %DT="",X="T-23M" D ^%DT S STDT=+Y Q:$P(ZERO,U,3)'<STDT D
- ..S X1=STDT,X2=-7 D C^%DTC S TYDT=X
- .N PROV,SEEN,PRECP D SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN) Q:SEEN
- .;flag
- .S DIE="^SCPT(404.43,",DR=".15////"_SDDT,DA=ENTRY D ^DIE
- .S TPZ=$G(^SCTM(404.57,+POS,2))
- .I "TP"[$P(TPZ,U,9) I $G(PROV) S CNT=CNT+1,^TMP("SCF",$J,PROV,CNT,ENTRY)=""
- .I $P(TPZ,U,10),$G(PRECP) S CNT=CNT+1,^TMP("SCF",$J,PRECP,CNT,ENTRY)=""
- Q
- SEEN(DFN,POS,TYDT,SDDT,PROV,PROVP,SEEN) ;
- S SEEN=0,PROVP=""
- N SCPRO,I,PRO,X,SCPRDTS,SCPR,PREC
- S PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
- S SCPRDTS("BEGIN")=TYDT,SCPRDTS("END")=SDDT,SCPRDTS("INCL")=0
- S X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
- S I=0 F S I=$O(SCPR(I)) Q:'I S SCPRO(+SCPR(I))="",SCPRO(+SCPR(I),I)=$P(SCPR(I),U,9,10) D
- .S PREC=$P(SCPR(I),U,12)
- .I PREC,PREC'=POS S PROVP=+$$GETPRTP^SCAPMCU2(PREC,SDDT) S SCPRO(+PROVP)="" S SCPRO(+PROVP,I)=$P(SCPR(I),U,9,10)
- F I=TYDT:0 S I=$O(^SCE("ADFN",DFN,I)) Q:'I D Q:SEEN
- .S J=0 F 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
- ..S PRO=0 F S PRO=$O(SCPRO(PRO)) Q:'PRO D Q:SEEN
- ...I $D(^SDD(409.44,"AO",J,$G(PRO))) D CHK I SEEN=1 Q
- ...N V F V=0:0 S V=$O(^AUPNVPRV("AD",VISIT,V)) Q:'V I PRO=(+$G(^AUPNVPRV(V,0))) D CHK I SEEN=1 Q
- Q
- CHK ;
- N SDX S SDX="" F S SDX=$O(SCPRO(PRO,SDX)) Q:SDX="" D Q:SEEN
- .I $P(SCPRO(PRO,SDX),U,2)="" D Q
- ..I I'<$P(SCPRO(PRO,SDX),U) S SEEN=1
- .I I'<TYDT&(I'>$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)="<DATA>"
- 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)))<J S X=0 Q
- I '$D(^SCTM(404.52,"AIDT",+A,1,J,D0)) S X=0 Q
- S X=1 Q
- SUM(PR,POSI) ;get pos for prov
- N I,INS,ZERO,SCA,TEAM,FTEE,Z
- S I="",FTEE=0
- F S I=$O(^SCTM(404.52,"C",PR,I),-1) Q:'I D
- .S ZERO=$G(^SCTM(404.52,I,0)) Q:$D(SCA(+ZERO)) Q:(POSI=(+ZERO)) S SCA(+ZERO)=""
- .S INS=$P($G(^SCTM(404.51,+$P($G(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
- .S ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5) Q:'ACTIVE
- .S (Z,ZERO)=$G(^SCTM(404.52,+$P(ACTIVE,U,4),0)) Q:$P(Z,U,3)'=PR
- .S ACTIVE=$$DATES^SCAPMCU1(404.59,+Z,DT+.5) Q:'ACTIVE
- .S Z=$G(^SCTM(404.57,+Z,0))
- .;Q:'$P(Z,U,4) ;Cannot be primary; enable all sd/581
- .S TEAM=$G(^SCTM(404.51,+$P(Z,U,2),0))
- .Q:'$P(TEAM,U,5)
- .S FTEE=FTEE+$P(ZERO,U,9)
- Q FTEE
- FTEECHK(DATA,PAIEN) ;check Ftee>1
- ;SD*5.3*504 change begin - ensure passed FTEE is numeric
- N X,X1,X2,FTEE
- S DATA=0
- D:$P(PAIEN,U,2)'="" Q:DATA=99.1
- .S X=$$TRIM^XLFSTR($P(PAIEN,U,2),"R"," ")
- .S X1=$P(X,"."),X1=$S(X1'="":X1,1:0)
- .S X2=$P(X,".",2,3),X2=$$TRIM^XLFSTR(X2,"L","0"),X2=$S(X2'="":X2,1:0)
- .S:X1<0!(+X1'=X1)!(+X2'=X2)!(X2'=$TR(X2,".","")) DATA=99.1
- .Q
- ;SD*5.3*504 change end
- 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)))<J Q
- S K=0 S K=$O(^SCTM(404.52,"AIDT",+INFO,1,J,K)) Q:'K
- S ZERO=$G(^SCTM(404.52,+K,0))
- ;Get person class for provider
- S PCLASS=$$GET^XUA4A72(+$P(ZERO,U,3))
- ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
- I '$D(^SD(403.46,+$P(INFO,U,3),2,"B",+PCLASS)) S DATA="1^Person Class of "_$$GET1^DIQ(200,(+$P(ZERO,U,3))_",",.01)_" is not valid in this Role." D POSCHK^SCMCTSK4
- Q
- SEED ;seed one patient/provider
- W !,"To retransmit all patients for a given provider press return to select the provider",!!
- N DIC,SCADT,SCDDT,SCPAI
- 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="^DPT(",DIC(0)="MEQA" D ^DIC G PRSEED:Y'>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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCTSK1 10187 printed Feb 19, 2025@00:07:59 Page 2
- 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
- +1 ;;5.3;Scheduling;**297,498,527,499,532,504,581**;AUG 13, 1993;Build 16
- +2 QUIT
- INACTIVE ;
- +1 ;Flag patients
- +2 NEW I,CNT,SC297,TPZ,TYDT,TEAMN,STDT,Q,SDDT,STDD
- SET CNT=0
- +3 DO DT^DICRW
- +4 NEW SD1
- SET SDDT=""
- FOR SD1=DT,DT-1
- IF $DATA(^XTMP("SCMCTSK2-"_SD1,$JOB,"START"))
- SET SDDT=SD1
- QUIT
- +5 IF SDDT'>0
- DO DT^DICRW
- SET SDDT=DT
- +6 SET %DT=""
- SET X="T-11M"
- DO ^%DT
- SET STDD=+Y
- +7 SET A="^SCPT(404.43,""ADFN"""
- SET L=""""""
- +8 SET Q=A_")"
- +9 FOR
- SET Q=$QUERY(@Q)
- if Q'[A
- QUIT
- Begin DoDot:1
- +10 SET ENTRY=+$PIECE(Q,",",6)
- +11 SET ZERO=$GET(^SCPT(404.43,+ENTRY,0))
- +12 IF $PIECE(ZERO,U,15)
- QUIT
- +13 SET POS=+$PIECE(ZERO,U,2)
- +14 ;UNASS
- IF $PIECE(ZERO,U,4)
- QUIT
- +15 ;Not PC
- IF '$PIECE(ZERO,U,5)
- QUIT
- +16 ;<11 months
- IF $PIECE(ZERO,U,3)>STDD
- QUIT
- +17 ;get preceptor
- +18 SET PREC=$$DATES^SCAPMCU1(404.53,+POS)
- SET PREC=$SELECT(PREC:$PIECE($GET(^SCTM(404.53,+$PIECE(PREC,U,4),0)),U,6),1:+POS)
- +19 SET DFN=$PIECE(Q,",",3)
- +20 IF $GET(XPDIDTOT)
- IF ('(DFN#5))
- DO UPDATE^XPDID(DFN)
- +21 SET TEAM=$PIECE(Q,",",4)
- SET TEAMNM=$PIECE($GET(^SCTM(404.51,+TEAM,0)),U)
- +22 NEW STDT
- SET %DT=""
- SET X="T-12M"
- DO ^%DT
- SET STDT=+Y
- +23 ;N-new or E-est
- +24 NEW NEW
- +25 IF $PIECE(ZERO,U,3)<STDT
- SET NEW=0
- +26 IF '$TEST
- SET NEW=1
- +27 NEW TYDT
- +28 IF NEW
- NEW STDT
- SET %DT=""
- SET X="T-11M"
- DO ^%DT
- SET STDT=+Y
- Begin DoDot:2
- +29 SET X1=STDT
- SET X2=-7
- DO C^%DTC
- SET TYDT=X
- End DoDot:2
- +30 IF 'NEW
- NEW STDT
- SET %DT=""
- SET X="T-23M"
- DO ^%DT
- SET STDT=+Y
- if $PIECE(ZERO,U,3)'<STDT
- QUIT
- Begin DoDot:2
- +31 SET X1=STDT
- SET X2=-7
- DO C^%DTC
- SET TYDT=X
- End DoDot:2
- +32 NEW PROV,SEEN,PRECP
- DO SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)
- if SEEN
- QUIT
- +33 ;flag
- +34 SET DIE="^SCPT(404.43,"
- SET DR=".15////"_SDDT
- SET DA=ENTRY
- DO ^DIE
- +35 SET TPZ=$GET(^SCTM(404.57,+POS,2))
- +36 IF "TP"[$PIECE(TPZ,U,9)
- IF $GET(PROV)
- SET CNT=CNT+1
- SET ^TMP("SCF",$JOB,PROV,CNT,ENTRY)=""
- +37 IF $PIECE(TPZ,U,10)
- IF $GET(PRECP)
- SET CNT=CNT+1
- SET ^TMP("SCF",$JOB,PRECP,CNT,ENTRY)=""
- End DoDot:1
- +38 QUIT
- SEEN(DFN,POS,TYDT,SDDT,PROV,PROVP,SEEN) ;
- +1 SET SEEN=0
- SET PROVP=""
- +2 NEW SCPRO,I,PRO,X,SCPRDTS,SCPR,PREC
- +3 SET PROV=+$$GETPRTP^SCAPMCU2(POS,SDDT)
- +4 SET SCPRDTS("BEGIN")=TYDT
- SET SCPRDTS("END")=SDDT
- SET SCPRDTS("INCL")=0
- +5 SET X=$$PRTP^SCAPMC(POS,"SCPRDTS","SCPR")
- +6 SET I=0
- FOR
- SET I=$ORDER(SCPR(I))
- if 'I
- QUIT
- SET SCPRO(+SCPR(I))=""
- SET SCPRO(+SCPR(I),I)=$PIECE(SCPR(I),U,9,10)
- Begin DoDot:1
- +7 SET PREC=$PIECE(SCPR(I),U,12)
- +8 IF PREC
- IF PREC'=POS
- SET PROVP=+$$GETPRTP^SCAPMCU2(PREC,SDDT)
- SET SCPRO(+PROVP)=""
- SET SCPRO(+PROVP,I)=$PIECE(SCPR(I),U,9,10)
- End DoDot:1
- +9 FOR I=TYDT:0
- SET I=$ORDER(^SCE("ADFN",DFN,I))
- if 'I
- QUIT
- Begin DoDot:1
- +10 SET J=0
- FOR
- SET J=$ORDER(^SCE("ADFN",DFN,I,J))
- if 'J
- QUIT
- Begin DoDot:2
- +11 NEW VISIT
- SET VISIT=+$PIECE($GET(^SCE(J,0)),U,5)
- IF $GET(^SCE(J,0))<$GET(TYDT)
- QUIT
- +12 SET PRO=0
- FOR
- SET PRO=$ORDER(SCPRO(PRO))
- if 'PRO
- QUIT
- Begin DoDot:3
- +13 IF $DATA(^SDD(409.44,"AO",J,$GET(PRO)))
- DO CHK
- IF SEEN=1
- QUIT
- +14 NEW V
- FOR V=0:0
- SET V=$ORDER(^AUPNVPRV("AD",VISIT,V))
- if 'V
- QUIT
- IF PRO=(+$GET(^AUPNVPRV(V,0)))
- DO CHK
- IF SEEN=1
- QUIT
- End DoDot:3
- if SEEN
- QUIT
- End DoDot:2
- if SEEN
- QUIT
- End DoDot:1
- if SEEN
- QUIT
- +15 QUIT
- CHK ;
- +1 NEW SDX
- SET SDX=""
- FOR
- SET SDX=$ORDER(SCPRO(PRO,SDX))
- if SDX=""
- QUIT
- Begin DoDot:1
- +2 IF $PIECE(SCPRO(PRO,SDX),U,2)=""
- Begin DoDot:2
- +3 IF I'<$PIECE(SCPRO(PRO,SDX),U)
- SET SEEN=1
- End DoDot:2
- QUIT
- +4 IF I'<TYDT&(I'>$PIECE(SCPRO(PRO,SDX),U,2))
- SET SEEN=1
- End DoDot:1
- if SEEN
- QUIT
- +5 QUIT
- DIS ;disch
- +1 NEW ZERO
- SET ZERO=$GET(^SCPT(404.43,+ENTRY,0))
- +2 IF $PIECE(ZERO,U,4)
- QUIT
- +3 DO DIS2^SCMCTSK7
- +4 QUIT
- CHKENR(DATA,INFO) ;check if patient enrolled in teamposition clinic
- +1 SET DATA(0)=-1
- +2 QUIT
- EXTEND(DATA,SCTEAM) ;to inact. in next 60 days
- +1 ;IEN^POSITION^PATIENT^EXTENDED^REASON
- +2 KILL DATA,SCDATA,SDDATA
- +3 NEW CNT,I,J,K,A,POSA
- SET CNT=1
- SET SCTEAM=$GET(SCTEAM)
- SET DATA(1)="<DATA>"
- +4 DO DT^DICRW
- +5 NEW SD1
- SET SDDT=""
- FOR SD1=DT,DT-1
- IF $DATA(^XTMP("SCMCTSK2-"_SD1,$JOB,"START"))
- SET SDDT=SD1
- QUIT
- +6 IF SDDT'>0
- DO DT^DICRW
- SET SDDT=DT
- +7 SET X="T-9M"
- DO ^%DT
- SET STDT=Y
- +8 ;MAKE THIS 21
- SET X="T-21M"
- DO ^%DT
- SET TYDT=+Y
- +9 SET POSA=""
- +10 SET POS=+$PIECE(SCTEAM,U,2)
- IF POS
- DO POS
- DO EX1
- QUIT
- +11 FOR
- SET POSA=$ORDER(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA))
- if POSA=""
- QUIT
- Begin DoDot:1
- +12 FOR POS=0:0
- SET POS=$ORDER(^SCTM(404.57,"ATMPOS",+SCTEAM,POSA,POS))
- if 'POS
- QUIT
- DO POS
- if CNT>100
- QUIT
- End DoDot:1
- if CNT>100
- QUIT
- +13 IF CNT>100
- SET DATA(1)="TOO MANY"
- QUIT
- EX1 SET A="SDDATA"
- SET CNT=1
- FOR
- SET A=$QUERY(@A)
- if A=""
- QUIT
- Begin DoDot:1
- +1 SET B=@A
- +2 SET DATA(CNT)=(+$PIECE(B,U,3))_U_$TRANSLATE($PIECE($PIECE(A,"(",2),","),$CHAR(34))_U_$TRANSLATE($PIECE(B,U,2),$CHAR(34))_U_$PIECE($GET(^SCPT(404.43,+$PIECE(B,U,3),0)),U,13)_U_$PIECE($GET(^SCPT(404.43,+$PIECE(B,U,3),0)),U,14)
- +3 SET CNT=CNT+1
- End DoDot:1
- +4 QUIT
- POS ;Position inact
- IF '$$DATES^SCAPMCU1(404.59,POS)
- QUIT
- +1 ;Not PC
- IF '$PIECE($GET(^SCTM(404.57,POS,0)),U,4)
- QUIT
- +2 ;patients for position
- +3 KILL ^TMP("SC TMP LIST",$JOB)
- +4 SET X=$$PTTP^SCAPMC(POS,"",.SCLIST,.SCERR)
- +5 SET J=0
- FOR
- SET J=$ORDER(@SCLIST@(J))
- if 'J
- QUIT
- SET SCDATA=^(J)
- Begin DoDot:1
- +6 NEW J
- IF $PIECE(SCDATA,U,4)>STDT
- QUIT
- +7 IF '$PIECE($GET(^SCPT(404.43,+$PIECE(SCDATA,U,3),0)),U,5)
- QUIT
- +8 IF '$PIECE($GET(^SCPT(404.43,+$PIECE(SCDATA,U,3),0)),U,15)
- QUIT
- +9 SET DFN=+SCDATA
- +10 DO SEEN(DFN,POS,TYDT,SDDT,.PROV,.PRECP,.SEEN)
- if SEEN
- QUIT
- +11 SET SDDATA($PIECE($GET(^SCTM(404.57,POS,0)),U),$PIECE(SCDATA,U,2),+SCDATA)=SCDATA
- SET CNT=CNT+1
- End DoDot:1
- +12 KILL @SCLIST
- +13 QUIT
- FILE(RES,DATA) ;File data on FTEE
- +1 NEW I
- +2 FOR I=1:1
- if '$DATA(DATA(I))
- QUIT
- Begin DoDot:1
- +3 SET $PIECE(DATA(I),U,7)=$TRANSLATE($PIECE(DATA(I),U,7),"[]")
- +4 SET ZERO=$GET(^SCPT(404.43,+DATA(I),0))
- +5 IF $PIECE(ZERO,U,13)=$PIECE(DATA(I),U,6)
- IF $PIECE(ZERO,U,14)=$PIECE(DATA(I),U,7)
- QUIT
- +6 SET FLDA(404.43,(+DATA(I))_",",.13)=$PIECE(DATA(I),U,6)
- +7 SET FLDA(404.43,(+DATA(I))_",",.14)=$EXTRACT($PIECE(DATA(I),U,7),1,50)
- +8 SET FLDA(404.43,(+DATA(I))_",",.16)="`"_(+$GET(DUZ))
- End DoDot:1
- +9 IF $ORDER(FLDA(0))
- DO FILE^DIE("E","FLDA","ERR")
- +10 QUIT
- SCREEN ;Active assign. screen
- +1 NEW A
- SET A=$GET(^SCTM(404.52,D0,0))
- +2 NEW J
- SET J=-(DT+1)
- SET J=$ORDER(^SCTM(404.52,"AIDT",+A,1,J))
- IF J=""
- SET X=0
- QUIT
- +3 ;Not PC
- IF '$PIECE($GET(^SCTM(404.57,+A,0)),U,4)
- QUIT
- +4 ;Not an active position
- IF '$$DATES^SCAPMCU1(404.59,+A)
- QUIT
- +5 IF $ORDER(^SCTM(404.52,"AIDT",+A,0,-(DT+1)))<J
- SET X=0
- QUIT
- +6 IF '$DATA(^SCTM(404.52,"AIDT",+A,1,J,D0))
- SET X=0
- QUIT
- +7 SET X=1
- QUIT
- SUM(PR,POSI) ;get pos for prov
- +1 NEW I,INS,ZERO,SCA,TEAM,FTEE,Z
- +2 SET I=""
- SET FTEE=0
- +3 FOR
- SET I=$ORDER(^SCTM(404.52,"C",PR,I),-1)
- if 'I
- QUIT
- Begin DoDot:1
- +4 SET ZERO=$GET(^SCTM(404.52,I,0))
- if $DATA(SCA(+ZERO))
- QUIT
- if (POSI=(+ZERO))
- QUIT
- SET SCA(+ZERO)=""
- +5 SET INS=$PIECE($GET(^SCTM(404.51,+$PIECE($GET(^SCTM(404.57,+ZERO,0)),U,2),0)),U,7)
- +6 SET ACTIVE=$$DATES^SCAPMCU1(404.52,+ZERO,DT+.5)
- if 'ACTIVE
- QUIT
- +7 SET (Z,ZERO)=$GET(^SCTM(404.52,+$PIECE(ACTIVE,U,4),0))
- if $PIECE(Z,U,3)'=PR
- QUIT
- +8 SET ACTIVE=$$DATES^SCAPMCU1(404.59,+Z,DT+.5)
- if 'ACTIVE
- QUIT
- +9 SET Z=$GET(^SCTM(404.57,+Z,0))
- +10 ;Q:'$P(Z,U,4) ;Cannot be primary; enable all sd/581
- +11 SET TEAM=$GET(^SCTM(404.51,+$PIECE(Z,U,2),0))
- +12 if '$PIECE(TEAM,U,5)
- QUIT
- +13 SET FTEE=FTEE+$PIECE(ZERO,U,9)
- End DoDot:1
- +14 QUIT FTEE
- FTEECHK(DATA,PAIEN) ;check Ftee>1
- +1 ;SD*5.3*504 change begin - ensure passed FTEE is numeric
- +2 NEW X,X1,X2,FTEE
- +3 SET DATA=0
- +4 if $PIECE(PAIEN,U,2)'=""
- Begin DoDot:1
- +5 SET X=$$TRIM^XLFSTR($PIECE(PAIEN,U,2),"R"," ")
- +6 SET X1=$PIECE(X,".")
- SET X1=$SELECT(X1'="":X1,1:0)
- +7 SET X2=$PIECE(X,".",2,3)
- SET X2=$$TRIM^XLFSTR(X2,"L","0")
- SET X2=$SELECT(X2'="":X2,1:0)
- +8 if X1<0!(+X1'=X1)!(+X2'=X2)!(X2'=$TRANSLATE(X2,".",""))
- SET DATA=99.1
- +9 QUIT
- End DoDot:1
- if DATA=99.1
- QUIT
- +10 ;SD*5.3*504 change end
- +11 NEW A
- SET A=$GET(^SCTM(404.52,+PAIEN,0))
- SET FTEE=$$SUM(+$PIECE(PAIEN,U,3),+A)
- +12 SET DATA=0
- +13 SET DATA=FTEE+$PIECE(PAIEN,U,2)
- +14 QUIT
- SORT(DIPA,SDD) ;sort tmpl
- +1 NEW DIC
- +2 SET DIC=4
- SET DIC(0)="ZME"
- +3 SET DIC("S")="I $D(^SCTM(404.51,""AINST"",+Y))"
- +4 SET DIR("A")="Start with Institution"
- SET DIR("B")="FIRST"
- SET DIR(0)="F"
- DO ^DIR
- +5 IF X="FIRST"
- SET DIPA("SI")=""
- SET DIPA("EI")="zzz"
- SET SDD=1
- QUIT
- +6 DO ^DIC
- IF Y<0
- SET DIPA("SI")=X
- SET SDD=X
- if SDD[U
- QUIT
- Begin DoDot:1
- +7 SET DIR("A")="Go to Institutiton"
- SET DIR("B")="LAST"
- SET DIR(0)="F"
- DO ^DIR
- +8 IF X="LAST"
- SET DIPA("EI")="zzz"
- End DoDot:1
- +9 IF Y>0
- SET DIPA("SI")=$PIECE(Y(0),U)
- SET DIC(0)="AZQME"
- SET DIC("A")="Go to Institution: "
- +10 DO ^DIC
- +11 IF Y>0
- SET DIPA("EI")=$PIECE(Y(0),U)
- +12 IF Y<0
- SET DIPA("EI")=X
- SET SDD=X
- if SDD[U
- QUIT
- +13 SET SDD=1
- QUIT
- FTEERPT ;FTEE REPORT
- +1 DO FTERPT^SCMCTSK6
- QUIT
- +2 QUIT
- POSCHK(DATA,INFO) ;
- +1 NEW PCLASS
- +2 ;TEAM POSITION IEN^PC^STANDARD POSITITION IEN
- +3 IF '$PIECE(INFO,U,3)
- SET DATA="1^Role Must be Entered"
- QUIT
- +4 IF $PIECE(INFO,U,2)
- IF '$PIECE($GET(^SD(403.46,+$PIECE(INFO,U,3),0)),U,3)
- SET DATA="1^This Role cannot provide Primary Care"
- QUIT
- +5 IF $PIECE(INFO,U,2)
- IF ($PIECE($GET(^SD(403.46,+$PIECE(INFO,U,3),0)),U,3)=2)
- IF '$$DATES^SCAPMCU1(404.53,+INFO)
- SET DATA="1^This Role cannot provide Primary Care unless Precepted"
- QUIT
- +6 SET DATA=0
- +7 IF ('INFO)!('$PIECE(INFO,U,2))
- QUIT
- +8 ;Is provider role acceptable?
- +9 SET J=-(DT+1)
- SET J=$ORDER(^SCTM(404.52,"AIDT",+INFO,1,J))
- if J=""
- QUIT
- +10 IF $ORDER(^SCTM(404.52,"AIDT",+INFO,0,-(DT+1)))<J
- QUIT
- +11 SET K=0
- SET K=$ORDER(^SCTM(404.52,"AIDT",+INFO,1,J,K))
- if 'K
- QUIT
- +12 SET ZERO=$GET(^SCTM(404.52,+K,0))
- +13 ;Get person class for provider
- +14 SET PCLASS=$$GET^XUA4A72(+$PIECE(ZERO,U,3))
- +15 ;IEN^Occupation^specialty^sub-specialty^Effective date^expiration date^VA Code^specialty code
- +16 IF '$DATA(^SD(403.46,+$PIECE(INFO,U,3),2,"B",+PCLASS))
- SET DATA="1^Person Class of "_$$GET1^DIQ(200,(+$PIECE(ZERO,U,3))_",",.01)_" is not valid in this Role."
- DO POSCHK^SCMCTSK4
- +17 QUIT
- SEED ;seed one patient/provider
- +1 WRITE !,"To retransmit all patients for a given provider press return to select the provider",!!
- +2 NEW DIC,SCADT,SCDDT,SCPAI
- +3 SET SC177=$$PDAT^SCMCGU("SD*5.3*177")
- +4 IF +SC177=0
- Begin DoDot:1
- +5 SET SC2=" Unable to obtain SD*5.3*177 Installation Date."
- +6 DO MSG^SCMCCV6(SC1,SC2)
- +7 QUIT
- End DoDot:1
- QUIT
- +8 SET DIC="^DPT("
- SET DIC(0)="MEQA"
- DO ^DIC
- if Y'>0
- GOTO PRSEED
- +9 ;event filer for 1 patient
- +10 SET SCDFN=+Y
- WRITE !,SCDFN
- SCDFN SET SC1="^SCPT(404.43,""APCPOS"",SCDFN,1)"
- +1 ;quit if no PC assign
- +2 if '$DATA(@SC1)
- QUIT
- +3 SET SCADT=0
- +4 FOR
- SET SCADT=$ORDER(@SC1@(SCADT))
- if SCADT=""
- QUIT
- Begin DoDot:1
- +5 SET SCTP=0
- +6 FOR
- SET SCTP=$ORDER(@SC1@(SCADT,SCTP))
- if 'SCTP
- QUIT
- Begin DoDot:2
- +7 ; quit if team position does not exist
- +8 if '$DATA(^SCTM(404.57,SCTP,0))
- QUIT
- +9 SET SCPAI=0
- +10 FOR
- SET SCPAI=$ORDER(@SC1@(SCADT,SCTP,SCPAI))
- if 'SCPAI
- QUIT
- Begin DoDot:3
- +11 SET SCDDT=$PIECE($GET(^SCPT(404.43,SCPAI,0)),U,4)
- +12 ;quit if not active within date range
- +13 if $$DTCHK^SCAPU1(SC177,DT,0,SCADT,SCDDT)<1
- QUIT
- +14 NEW SCVAR
- SET SCVAR=SCPAI_";SCPT(404.43,"
- +15 ;add to HL7 event file
- +16 if $DATA(^SCPT(404.48,"AACXMIT",SCVAR))
- QUIT
- +17 if $$CHECK^SCMCHLB1(SCVAR)'=1
- QUIT
- +18 DO ADD^SCMCHLE("NOW",SCVAR,SCDFN,SCTP)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +19 QUIT
- PRSEED ;seed practitioner
- +1 NEW AH,SC177
- +2 SET SC177=$$PDAT^SCMCGU("SD*5.3*177")
- +3 IF +SC177=0
- Begin DoDot:1
- +4 SET SC2=" No SD*5.3*177 Installation Date."
- +5 DO MSG^SCMCCV6(SC1,SC2)
- End DoDot:1
- QUIT
- +6 SET DIC=200
- SET DIC(0)="MEQA"
- SET DIC("A")="Select Provider: "
- DO ^DIC
- if Y'>0
- QUIT
- +7 SET SCPROV=+Y
- +8 FOR AH=0:0
- SET AH=$ORDER(^SCTM(404.52,"C",SCPROV,AH))
- if 'AH
- QUIT
- SET TP=+$GET(^SCTM(404.52,+AH,0))
- Begin DoDot:1
- +9 if $DATA(SCTP(TP))
- QUIT
- +10 SET SCTP(TP)=1
- +11 FOR SCDFN=0:0
- SET SCDFN=$ORDER(^SCPT(404.43,"ADFN",SCDFN))
- if 'SCDFN
- QUIT
- IF $DATA(^(SCDFN,TP))
- IF '$DATA(SCU(SCDFN))
- DO SCDFN
- SET SCU(SCDFN)=1
- +12 if '$PIECE($GET(^SCTM(404.57,TP,0)),U,4)
- QUIT
- +13 SET SCVAR=AH_";SCTM(404.52,"
- +14 ;Quit if an event entry already exists
- +15 NEW QUIT,I
- SET QUIT=0
- +16 FOR I=0:0
- SET I=$ORDER(^SCPT(404.48,"AACXMIT",SCVAR,I))
- if 'I
- QUIT
- IF $PIECE($GET(^SCPT(404.48,I,0)),U,8)
- SET QUIT=1
- QUIT
- +17 if QUIT
- QUIT
- +18 DO ADD^SCMCHLE("NOW",SCVAR,,AH,1)
- End DoDot:1
- +19 QUIT
- INCON ;inconsistent PC assignments
- +1 NEW POS
- +2 DO INCON^SCMCTSK3
- +3 QUIT
- INCONR ;inconsistent report
- +1 NEW BY
- +2 KILL ^TMP("SCMCTSK",$JOB)
- +3 SET DIC="^SCTM(404.57,"
- SET (FLDS,BY)="[SCMC INCONSISTENT]"
- SET DIOBEG="D INCON^SCMCTSK1"
- +4 DO EN1^DIP
- +5 QUIT
- INACTDT(PA) ;Scheduled inactivation date.
- +1 DO INACT^SCMCTSK3
- QUIT
- IU(DFN) ;is patient inactivity unassigned
- +1 QUIT $$IU^SCMCTSK3(DFN)
- +2 NEW I,A,B,DATA