- SCMCWAIT ;ALB/SCK - Broker Utilities for Placement on Wait List ; 30 Oct 2002 3:42 PM ; Compiled May 25, 2007 09:07:17
- ;;5.3;Scheduling;**264,297,446**;AUG 13, 1993;Build 77
- ;
- Q
- ;
- WAIT(SCOK,SC) ; Place patient on wait list
- ; 'SC BLD PAT CLN LIST'
- ;
- ;M ^JDS=SC
- N COMMENT,SDTM,SDCNT,SDINS,SDINTR,SDMTM,SDREJ,SDWLIN
- S TEAM=$G(SC("TEAM")),POS=$G(SC("POSITION")),DFN=$G(SC("DFN")),COMMENT=$G(SC("COMMENT")),SC=$G(SC("SC"))
- S SDWLIN=+$P($G(^SCTM(404.51,+$G(TEAM),0)),U,7),SDINTR=$G(SC("SDINTR")),SDREJ=$G(SC("SDREJ")),SDMTM=$G(SC("SDMTM"))
- ; check if transfer and if multiple teams in institution
- S SDCNT=0,SDINTR="",SDREJ="",SDMTM="",SDCC=TEAM
- ;identify INTRA-transfer
- ;- is patient assigned to PC provider?
- I 'POS&TEAM D PCPVER(DFN,.SDTM) D ; return current PCP team or 0
- .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution
- .I 'SDTM S SDINS="" F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
- ..;check available PCMM teams in other institutions and if so set up rejection flag
- ..N SDT S SDCNT=0,SDT=""
- ..F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
- ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
- ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
- ...N SCTMMAX S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
- ...I SCTMCT<SCTMMAX S SDREJ=1
- ..;find all teams from institution SDWLIN
- .I SDINTR S SDCNT=0,SDT="" D
- ..F S SDT=$O(^SCTM(404.51,"AINST",SDWLIN,SDT)) Q:SDT="" I $P(^SCTM(404.51,SDT,0),U,5)=1 S TEAM(SDT)="",SDCNT=SDCNT+1
- I SDCNT>1 S SDMTM=1 S SDCC="" F S SDCC=$O(TEAM(SDCC)) Q:SDCC="" N DR,Y D WT Q
- I SDCNT'>1 D WT Q
- WT N RES D INPUT^SDWLRP1(.RES,DFN_U_$S(POS:2,1:1)_U_SDCC_U_$S(POS:POS_U_DUZ,1:U_DUZ)_U_COMMENT_U_SC_U_SDINTR_U_SDREJ_U_SDMTM)
- I RES S SDWLRES=RES ; 446
- Q
- WAITS(DFN,TEAM,POS,SC) ; PLACE PATIENT ON WAIT LIST
- N SDCC,SDTEAM,SDINTR,SDMTM,SDREJ,SDWLIN,SDWLRES
- S SDTEAM=$G(TEAM)
- ; check if transfer and if multiple teams in institution
- S SDCNT=0,SDINTR="",SDREJ="",SDMTM="" I 'POS&TEAM D
- .S SDWLIN=$P($G(^SCTM(404.51,TEAM,0)),U,7)
- .;- is patient assigned to PC provider?
- I 'POS&TEAM D PCPVER(DFN,.SDTM) D ; return current PCP team or 0
- .I SDTM I $P($G(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN S SDINTR=1 ; inter transfer ; different institution
- .I 'SDTM S SDINS="" F S SDINS=$O(^SCTM(404.51,"AINST",SDINS)) Q:SDINS="" I SDINS'=SDWLIN D Q:SDREJ
- ..;check available PCMM teams in other institutions and if so set up rejection flag
- ..N SDT S SDCNT=0,SDT=""
- ..F S SDT=$O(^SCTM(404.51,"AINST",SDINS,SDT)) Q:SDT="" D Q:SDREJ
- ...I $$ACTTM^SCMCTMU(SDT)&($P($G(^SCTM(404.51,SDT,0)),U,5))&'$P($G(^SCTM(404.51,SDT,0)),U,10) D
- ...N SCTMCT S SCTMCT=$$TEAMCNT^SCAPMCU1(SDT) ;currently assigned
- ...N SCTMMAX S SCTMMAX=$P($$GETEAM^SCAPMCU3(SDT),"^",8) ;maximum set
- ...I SCTMCT<SCTMMAX S SDREJ=1
- ..;find all teams from institution SDWLIN
- .I SDINTR S SDCNT=0,SDT="" D
- ..F S SDT=$O(^SCTM(404.51,"AINST",SDWLIN,SDT)) Q:SDT="" I $P(^SCTM(404.51,SDT,0),U,5)=1 S TEAM(SDT)="",SDCNT=SDCNT+1
- I SDCNT>1 S SDMTM=1 S SDCC="" F S SDCC=$O(TEAM(SDCC)) Q:SDCC="" S TEAM=SDCC N DR,Y S SDWLRES=$$WMT
- I SDCNT'>1 N DR,Y S SDWLRES=$$WMT
- S TEAM=$G(SDTEAM) Q $G(SDWLRES)
- WMT() N RES
- D INPUT^SDWLRP1(.RES,DFN_U_$S(POS:2,1:1)_U_TEAM_U_$S(POS:POS_U_DUZ,1:U_DUZ)_"^^"_SC_U_SDINTR_U_SDREJ_U_SDMTM)
- I $G(RES) D
- .N DA,DIE,DIK,DR,OK
- .S SDWLRES=RES ; 446
- .S OK=0,DA=+$P(RES,U,2),DIE="^SDWL(409.3,",DR="25;S OK=1"
- .D ^DIE
- .I 'OK S DIK=DIE D ^DIK W !,"Wait list entry deleted" S RES=0
- Q $G(RES)
- TEAMRM(DFN,TEAM) ;
- N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAM) Q ;not PC panel assignment
- I SDTM'=TEAM D CLONE(DFN,TEAM) Q ;TEAM IS NOT PCP
- ;close EWL entries only if assignment to PC panel, not necessarily to a team
- N I
- F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I S A=$G(^SDWL(409.3,I,0)) D
- .I 12'[$P(A,U,5) Q
- .;I $P(A,U,6)'=$G(TEAM) Q
- .I $G(^SDWL(409.3,I,"DIS")) Q
- .;INACTIVATE I
- .N FDA S FDA(409.3,I_",",21)="SA"
- .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
- .S FDA(409.3,I_",",20)=DUZ
- .D UPDATE^DIE("","FDA")
- Q
- POSRM(TEAMP,POS) ;
- ;
- S DFN=+$G(^SCPT(404.42,+$G(TEAMP),0))
- N SDTM D PCPVER(DFN,.SDTM) I 'SDTM D CLONE(DFN,TEAMP,POS) Q ;not PC panel assignment
- I SDTM'=TEAMP D CLONE(DFN,TEAMP,POS) Q
- I $G(POS) I '$P($G(^SCPT(404.43,+POS,0)),U,5) Q ;not pc
- I '$P($G(^SCPT(404.42,+$G(TEAMP),0)),U,8) Q ;not pc
- ;S ^JDS("TEAMP")=TEAMP,^JDS("POS")=POS,^JDS("DFN")=DFN
- N I
- F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I S A=$G(^SDWL(409.3,I,0)) D
- .I 12'[$P(A,U,5) Q
- .;I $P(A,U,7)'=$G(POS) Q
- .I $G(^SDWL(409.3,I,"DIS")) Q
- .N FDA S FDA(409.3,I_",",21)="SA",FDA(409.3,I_",",23)="C"
- .S FDA(409.3,I_",",19)=DT
- .S FDA(409.3,I_",",20)=DUZ
- .D FILE^DIE("","FDA")
- .;INACTIVATE
- Q
- CLONE(DFN,TEAM,POS) ;clean one entry only or two if position
- N I,SDONE S SDONE=0
- F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I S A=$G(^SDWL(409.3,I,0)) D Q:SDONE
- .I 12'[$P(A,U,5) Q
- .I $P(A,U,5)=1 I $P(A,U,6)'=$G(TEAM) Q
- .I $P(A,U,5)=2 I $P(A,U,6)'=$G(POS) Q
- .I $G(^SDWL(409.3,I,"DIS")) Q
- .;INACTIVATE I
- .N FDA S FDA(409.3,I_",",21)="SA"
- .S FDA(409.3,I_",",19)=DT,FDA(409.3,I_",",23)="C"
- .S FDA(409.3,I_",",20)=DUZ
- .D UPDATE^DIE("","FDA")
- .S SDONE=1
- Q
- PCPVER(DFN,SDTM) ;verify if PCP assignment
- S SDTM=0 ; return 0 if no PCP assignment
- K ^TMP("SDPCP",$J)
- N SDATE,SDPCP
- N SDI F SDI="BEGIN","END" S SDATE(SDI)=DT
- S SDATE="SDATE",SDPCP="^TMP(""SDPCP"",$J)"
- ;
- N SDI S SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDPCP)
- N SDII S SDII=0
- F S SDII=$O(^TMP("SDPCP",$J,DFN,"PCPOS",SDII)) Q:'SDII D
- .N SDX S SDX=^TMP("SDPCP",$J,DFN,"PCPOS",SDII)
- .I +$P(SDX,U,7)'=2 Q ;PCP role
- .I +$P(SDX,U,6)>0&(+$P(SDX,U,6)<DT) Q
- .S SDTM=$P(SDX,U,3)
- Q
- ONWAIT(DFN) ;is patient on wait list
- D DEM^VADPT I $G(VADM(6)) Q 9 ;Patient is dead
- N I,X
- S X=0
- F I=0:0 S I=$O(^SDWL(409.3,"B",+$G(DFN),I)) Q:'I S A=$G(^SDWL(409.3,I,0)) D Q:X
- .I 12'[$P(A,U,5) Q
- .I $G(^SDWL(409.3,I,"DIS")) Q
- .S X="3;ON WAITLIST TEAM: "_$P($G(^SCTM(404.51,+$P(A,U,6),0)),U)
- .I $P(A,U,7) S X=X_" POSITION: "_$P($G(^SCTM(404.57,+$P(A,U,7),0)),U)
- I X Q X
- ;Q X
- ;CHECK IF ON TEAM
- N SCD,SCDT,SCOK S SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1") I $D(SCD(1)) S X=1
- N SCPOS S SCOK=$$TPPT^SCAPMC(DFN,.SCDT,"","","","","","SCPOS","SCBKERR") I $D(SCPOS(1)) S X=2
- Q X
- ;CHECK IF ON POSITION
- SORT ;From sort template
- S X=0
- Q
- PC(RESULT,POS) ;rpc to see if provider can be pc
- N POENT,RES
- D ROLE(.RES,POS) I RES=1 S RESULT(0)=0 Q
- S POENT=+$O(^SCTM(404.52,"AIDT",+$G(POS),1,-(DT+.1))),POENT=$O(^(POENT,0))
- ;S PROV=+$P($G(^SCTM(404.52,+$G(POENT),0)),U,3)
- I 'POENT S RESULT(0)=1 Q
- N D0 S D0=+$G(POENT) D SORT S RESULT(0)=X
- Q
- ROLE(RESULT,POS) ;rpc to see if role of position is resident
- N ZERO S ZERO=$G(^SCTM(404.57,+$G(POS),0))
- I $P(ZERO,U,4) S RESULT=0 Q ;Already pc let them change it.
- S RESULT=0
- I $P($G(^SD(403.46,+$P(ZERO,U,3),0)),U)="RESIDENT (PHYSICIAN)" S RESULT=1
- Q
- SC(DFN) ;Is patient 0-50 sc%
- N TEAM,INST S TEAM=$P(DFN,U,2),INST=+$P($G(^SCTM(404.51,+TEAM,0)),U,7)
- S X=0,DFN=+DFN
- N A D ELIG^VADPT S A=$G(VAEL(3)) I $P(A,U)'="Y" Q 0
- I $P(A,U,2)<50 Q $P(A,U,2)
- Q 0
- SCLI(RESULT,SC) ;sc sc list
- K RESULT N RES
- S DFN=+$G(SC("DFN"))
- D SDSC^SDWLRP3(.RES,DFN) I RES=-1 S RESULT(0)=-1 Q
- S RESULT(0)="<RESULTS>" N CNT,I S CNT=1 F I=0:0 S I=$O(^TMP("SDWLRP3",$J,I)) Q:'I S RESULT(CNT)=^(I),CNT=CNT+1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCWAIT 7628 printed Jan 18, 2025@03:42:53 Page 2
- SCMCWAIT ;ALB/SCK - Broker Utilities for Placement on Wait List ; 30 Oct 2002 3:42 PM ; Compiled May 25, 2007 09:07:17
- +1 ;;5.3;Scheduling;**264,297,446**;AUG 13, 1993;Build 77
- +2 ;
- +3 QUIT
- +4 ;
- WAIT(SCOK,SC) ; Place patient on wait list
- +1 ; 'SC BLD PAT CLN LIST'
- +2 ;
- +3 ;M ^JDS=SC
- +4 NEW COMMENT,SDTM,SDCNT,SDINS,SDINTR,SDMTM,SDREJ,SDWLIN
- +5 SET TEAM=$GET(SC("TEAM"))
- SET POS=$GET(SC("POSITION"))
- SET DFN=$GET(SC("DFN"))
- SET COMMENT=$GET(SC("COMMENT"))
- SET SC=$GET(SC("SC"))
- +6 SET SDWLIN=+$PIECE($GET(^SCTM(404.51,+$GET(TEAM),0)),U,7)
- SET SDINTR=$GET(SC("SDINTR"))
- SET SDREJ=$GET(SC("SDREJ"))
- SET SDMTM=$GET(SC("SDMTM"))
- +7 ; check if transfer and if multiple teams in institution
- +8 SET SDCNT=0
- SET SDINTR=""
- SET SDREJ=""
- SET SDMTM=""
- SET SDCC=TEAM
- +9 ;identify INTRA-transfer
- +10 ;- is patient assigned to PC provider?
- +11 ; return current PCP team or 0
- IF 'POS&TEAM
- DO PCPVER(DFN,.SDTM)
- Begin DoDot:1
- +12 ; inter transfer ; different institution
- IF SDTM
- IF $PIECE($GET(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN
- SET SDINTR=1
- +13 IF 'SDTM
- SET SDINS=""
- FOR
- SET SDINS=$ORDER(^SCTM(404.51,"AINST",SDINS))
- if SDINS=""
- QUIT
- IF SDINS'=SDWLIN
- Begin DoDot:2
- +14 ;check available PCMM teams in other institutions and if so set up rejection flag
- +15 NEW SDT
- SET SDCNT=0
- SET SDT=""
- +16 FOR
- SET SDT=$ORDER(^SCTM(404.51,"AINST",SDINS,SDT))
- if SDT=""
- QUIT
- Begin DoDot:3
- +17 IF $$ACTTM^SCMCTMU(SDT)&($PIECE($GET(^SCTM(404.51,SDT,0)),U,5))&'$PIECE($GET(^SCTM(404.51,SDT,0)),U,10)
- Begin DoDot:4
- End DoDot:4
- +18 ;currently assigned
- NEW SCTMCT
- SET SCTMCT=$$TEAMCNT^SCAPMCU1(SDT)
- +19 ;maximum set
- NEW SCTMMAX
- SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SDT),"^",8)
- +20 IF SCTMCT<SCTMMAX
- SET SDREJ=1
- End DoDot:3
- if SDREJ
- QUIT
- +21 ;find all teams from institution SDWLIN
- End DoDot:2
- if SDREJ
- QUIT
- +22 IF SDINTR
- SET SDCNT=0
- SET SDT=""
- Begin DoDot:2
- +23 FOR
- SET SDT=$ORDER(^SCTM(404.51,"AINST",SDWLIN,SDT))
- if SDT=""
- QUIT
- IF $PIECE(^SCTM(404.51,SDT,0),U,5)=1
- SET TEAM(SDT)=""
- SET SDCNT=SDCNT+1
- End DoDot:2
- End DoDot:1
- +24 IF SDCNT>1
- SET SDMTM=1
- SET SDCC=""
- FOR
- SET SDCC=$ORDER(TEAM(SDCC))
- if SDCC=""
- QUIT
- NEW DR,Y
- DO WT
- QUIT
- +25 IF SDCNT'>1
- DO WT
- QUIT
- WT NEW RES
- DO INPUT^SDWLRP1(.RES,DFN_U_$SELECT(POS:2,1:1)_U_SDCC_U_$SELECT(POS:POS_U_DUZ,1:U_DUZ)_U_COMMENT_U_SC_U_SDINTR_U_SDREJ_U_SDMTM)
- +1 ; 446
- IF RES
- SET SDWLRES=RES
- +2 QUIT
- WAITS(DFN,TEAM,POS,SC) ; PLACE PATIENT ON WAIT LIST
- +1 NEW SDCC,SDTEAM,SDINTR,SDMTM,SDREJ,SDWLIN,SDWLRES
- +2 SET SDTEAM=$GET(TEAM)
- +3 ; check if transfer and if multiple teams in institution
- +4 SET SDCNT=0
- SET SDINTR=""
- SET SDREJ=""
- SET SDMTM=""
- IF 'POS&TEAM
- Begin DoDot:1
- +5 SET SDWLIN=$PIECE($GET(^SCTM(404.51,TEAM,0)),U,7)
- +6 ;- is patient assigned to PC provider?
- End DoDot:1
- +7 ; return current PCP team or 0
- IF 'POS&TEAM
- DO PCPVER(DFN,.SDTM)
- Begin DoDot:1
- +8 ; inter transfer ; different institution
- IF SDTM
- IF $PIECE($GET(^SCTM(404.51,SDTM,0)),U,7)'=SDWLIN
- SET SDINTR=1
- +9 IF 'SDTM
- SET SDINS=""
- FOR
- SET SDINS=$ORDER(^SCTM(404.51,"AINST",SDINS))
- if SDINS=""
- QUIT
- IF SDINS'=SDWLIN
- Begin DoDot:2
- +10 ;check available PCMM teams in other institutions and if so set up rejection flag
- +11 NEW SDT
- SET SDCNT=0
- SET SDT=""
- +12 FOR
- SET SDT=$ORDER(^SCTM(404.51,"AINST",SDINS,SDT))
- if SDT=""
- QUIT
- Begin DoDot:3
- +13 IF $$ACTTM^SCMCTMU(SDT)&($PIECE($GET(^SCTM(404.51,SDT,0)),U,5))&'$PIECE($GET(^SCTM(404.51,SDT,0)),U,10)
- Begin DoDot:4
- End DoDot:4
- +14 ;currently assigned
- NEW SCTMCT
- SET SCTMCT=$$TEAMCNT^SCAPMCU1(SDT)
- +15 ;maximum set
- NEW SCTMMAX
- SET SCTMMAX=$PIECE($$GETEAM^SCAPMCU3(SDT),"^",8)
- +16 IF SCTMCT<SCTMMAX
- SET SDREJ=1
- End DoDot:3
- if SDREJ
- QUIT
- +17 ;find all teams from institution SDWLIN
- End DoDot:2
- if SDREJ
- QUIT
- +18 IF SDINTR
- SET SDCNT=0
- SET SDT=""
- Begin DoDot:2
- +19 FOR
- SET SDT=$ORDER(^SCTM(404.51,"AINST",SDWLIN,SDT))
- if SDT=""
- QUIT
- IF $PIECE(^SCTM(404.51,SDT,0),U,5)=1
- SET TEAM(SDT)=""
- SET SDCNT=SDCNT+1
- End DoDot:2
- End DoDot:1
- +20 IF SDCNT>1
- SET SDMTM=1
- SET SDCC=""
- FOR
- SET SDCC=$ORDER(TEAM(SDCC))
- if SDCC=""
- QUIT
- SET TEAM=SDCC
- NEW DR,Y
- SET SDWLRES=$$WMT
- +21 IF SDCNT'>1
- NEW DR,Y
- SET SDWLRES=$$WMT
- +22 SET TEAM=$GET(SDTEAM)
- QUIT $GET(SDWLRES)
- WMT() NEW RES
- +1 DO INPUT^SDWLRP1(.RES,DFN_U_$SELECT(POS:2,1:1)_U_TEAM_U_$SELECT(POS:POS_U_DUZ,1:U_DUZ)_"^^"_SC_U_SDINTR_U_SDREJ_U_SDMTM)
- +2 IF $GET(RES)
- Begin DoDot:1
- +3 NEW DA,DIE,DIK,DR,OK
- +4 ; 446
- SET SDWLRES=RES
- +5 SET OK=0
- SET DA=+$PIECE(RES,U,2)
- SET DIE="^SDWL(409.3,"
- SET DR="25;S OK=1"
- +6 DO ^DIE
- +7 IF 'OK
- SET DIK=DIE
- DO ^DIK
- WRITE !,"Wait list entry deleted"
- SET RES=0
- End DoDot:1
- +8 QUIT $GET(RES)
- TEAMRM(DFN,TEAM) ;
- +1 ;not PC panel assignment
- NEW SDTM
- DO PCPVER(DFN,.SDTM)
- IF 'SDTM
- DO CLONE(DFN,TEAM)
- QUIT
- +2 ;TEAM IS NOT PCP
- IF SDTM'=TEAM
- DO CLONE(DFN,TEAM)
- QUIT
- +3 ;close EWL entries only if assignment to PC panel, not necessarily to a team
- +4 NEW I
- +5 FOR I=0:0
- SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
- if 'I
- QUIT
- SET A=$GET(^SDWL(409.3,I,0))
- Begin DoDot:1
- +6 IF 12'[$PIECE(A,U,5)
- QUIT
- +7 ;I $P(A,U,6)'=$G(TEAM) Q
- +8 IF $GET(^SDWL(409.3,I,"DIS"))
- QUIT
- +9 ;INACTIVATE I
- +10 NEW FDA
- SET FDA(409.3,I_",",21)="SA"
- +11 SET FDA(409.3,I_",",19)=DT
- SET FDA(409.3,I_",",23)="C"
- +12 SET FDA(409.3,I_",",20)=DUZ
- +13 DO UPDATE^DIE("","FDA")
- End DoDot:1
- +14 QUIT
- POSRM(TEAMP,POS) ;
- +1 ;
- +2 SET DFN=+$GET(^SCPT(404.42,+$GET(TEAMP),0))
- +3 ;not PC panel assignment
- NEW SDTM
- DO PCPVER(DFN,.SDTM)
- IF 'SDTM
- DO CLONE(DFN,TEAMP,POS)
- QUIT
- +4 IF SDTM'=TEAMP
- DO CLONE(DFN,TEAMP,POS)
- QUIT
- +5 ;not pc
- IF $GET(POS)
- IF '$PIECE($GET(^SCPT(404.43,+POS,0)),U,5)
- QUIT
- +6 ;not pc
- IF '$PIECE($GET(^SCPT(404.42,+$GET(TEAMP),0)),U,8)
- QUIT
- +7 ;S ^JDS("TEAMP")=TEAMP,^JDS("POS")=POS,^JDS("DFN")=DFN
- +8 NEW I
- +9 FOR I=0:0
- SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
- if 'I
- QUIT
- SET A=$GET(^SDWL(409.3,I,0))
- Begin DoDot:1
- +10 IF 12'[$PIECE(A,U,5)
- QUIT
- +11 ;I $P(A,U,7)'=$G(POS) Q
- +12 IF $GET(^SDWL(409.3,I,"DIS"))
- QUIT
- +13 NEW FDA
- SET FDA(409.3,I_",",21)="SA"
- SET FDA(409.3,I_",",23)="C"
- +14 SET FDA(409.3,I_",",19)=DT
- +15 SET FDA(409.3,I_",",20)=DUZ
- +16 DO FILE^DIE("","FDA")
- +17 ;INACTIVATE
- End DoDot:1
- +18 QUIT
- CLONE(DFN,TEAM,POS) ;clean one entry only or two if position
- +1 NEW I,SDONE
- SET SDONE=0
- +2 FOR I=0:0
- SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
- if 'I
- QUIT
- SET A=$GET(^SDWL(409.3,I,0))
- Begin DoDot:1
- +3 IF 12'[$PIECE(A,U,5)
- QUIT
- +4 IF $PIECE(A,U,5)=1
- IF $PIECE(A,U,6)'=$GET(TEAM)
- QUIT
- +5 IF $PIECE(A,U,5)=2
- IF $PIECE(A,U,6)'=$GET(POS)
- QUIT
- +6 IF $GET(^SDWL(409.3,I,"DIS"))
- QUIT
- +7 ;INACTIVATE I
- +8 NEW FDA
- SET FDA(409.3,I_",",21)="SA"
- +9 SET FDA(409.3,I_",",19)=DT
- SET FDA(409.3,I_",",23)="C"
- +10 SET FDA(409.3,I_",",20)=DUZ
- +11 DO UPDATE^DIE("","FDA")
- +12 SET SDONE=1
- End DoDot:1
- if SDONE
- QUIT
- +13 QUIT
- PCPVER(DFN,SDTM) ;verify if PCP assignment
- +1 ; return 0 if no PCP assignment
- SET SDTM=0
- +2 KILL ^TMP("SDPCP",$JOB)
- +3 NEW SDATE,SDPCP
- +4 NEW SDI
- FOR SDI="BEGIN","END"
- SET SDATE(SDI)=DT
- +5 SET SDATE="SDATE"
- SET SDPCP="^TMP(""SDPCP"",$J)"
- +6 ;
- +7 NEW SDI
- SET SDI=$$GETALL^SCAPMCA(DFN,.SDATE,SDPCP)
- +8 NEW SDII
- SET SDII=0
- +9 FOR
- SET SDII=$ORDER(^TMP("SDPCP",$JOB,DFN,"PCPOS",SDII))
- if 'SDII
- QUIT
- Begin DoDot:1
- +10 NEW SDX
- SET SDX=^TMP("SDPCP",$JOB,DFN,"PCPOS",SDII)
- +11 ;PCP role
- IF +$PIECE(SDX,U,7)'=2
- QUIT
- +12 IF +$PIECE(SDX,U,6)>0&(+$PIECE(SDX,U,6)<DT)
- QUIT
- +13 SET SDTM=$PIECE(SDX,U,3)
- End DoDot:1
- +14 QUIT
- ONWAIT(DFN) ;is patient on wait list
- +1 ;Patient is dead
- DO DEM^VADPT
- IF $GET(VADM(6))
- QUIT 9
- +2 NEW I,X
- +3 SET X=0
- +4 FOR I=0:0
- SET I=$ORDER(^SDWL(409.3,"B",+$GET(DFN),I))
- if 'I
- QUIT
- SET A=$GET(^SDWL(409.3,I,0))
- Begin DoDot:1
- +5 IF 12'[$PIECE(A,U,5)
- QUIT
- +6 IF $GET(^SDWL(409.3,I,"DIS"))
- QUIT
- +7 SET X="3;ON WAITLIST TEAM: "_$PIECE($GET(^SCTM(404.51,+$PIECE(A,U,6),0)),U)
- +8 IF $PIECE(A,U,7)
- SET X=X_" POSITION: "_$PIECE($GET(^SCTM(404.57,+$PIECE(A,U,7),0)),U)
- End DoDot:1
- if X
- QUIT
- +9 IF X
- QUIT X
- +10 ;Q X
- +11 ;CHECK IF ON TEAM
- +12 NEW SCD,SCDT,SCOK
- SET SCOK=$$TMPT^SCAPMC3(DFN,"SCDT","","SCD","SCER1")
- IF $DATA(SCD(1))
- SET X=1
- +13 NEW SCPOS
- SET SCOK=$$TPPT^SCAPMC(DFN,.SCDT,"","","","","","SCPOS","SCBKERR")
- IF $DATA(SCPOS(1))
- SET X=2
- +14 QUIT X
- +15 ;CHECK IF ON POSITION
- SORT ;From sort template
- +1 SET X=0
- +2 QUIT
- PC(RESULT,POS) ;rpc to see if provider can be pc
- +1 NEW POENT,RES
- +2 DO ROLE(.RES,POS)
- IF RES=1
- SET RESULT(0)=0
- QUIT
- +3 SET POENT=+$ORDER(^SCTM(404.52,"AIDT",+$GET(POS),1,-(DT+.1)))
- SET POENT=$ORDER(^(POENT,0))
- +4 ;S PROV=+$P($G(^SCTM(404.52,+$G(POENT),0)),U,3)
- +5 IF 'POENT
- SET RESULT(0)=1
- QUIT
- +6 NEW D0
- SET D0=+$GET(POENT)
- DO SORT
- SET RESULT(0)=X
- +7 QUIT
- ROLE(RESULT,POS) ;rpc to see if role of position is resident
- +1 NEW ZERO
- SET ZERO=$GET(^SCTM(404.57,+$GET(POS),0))
- +2 ;Already pc let them change it.
- IF $PIECE(ZERO,U,4)
- SET RESULT=0
- QUIT
- +3 SET RESULT=0
- +4 IF $PIECE($GET(^SD(403.46,+$PIECE(ZERO,U,3),0)),U)="RESIDENT (PHYSICIAN)"
- SET RESULT=1
- +5 QUIT
- SC(DFN) ;Is patient 0-50 sc%
- +1 NEW TEAM,INST
- SET TEAM=$PIECE(DFN,U,2)
- SET INST=+$PIECE($GET(^SCTM(404.51,+TEAM,0)),U,7)
- +2 SET X=0
- SET DFN=+DFN
- +3 NEW A
- DO ELIG^VADPT
- SET A=$GET(VAEL(3))
- IF $PIECE(A,U)'="Y"
- QUIT 0
- +4 IF $PIECE(A,U,2)<50
- QUIT $PIECE(A,U,2)
- +5 QUIT 0
- SCLI(RESULT,SC) ;sc sc list
- +1 KILL RESULT
- NEW RES
- +2 SET DFN=+$GET(SC("DFN"))
- +3 DO SDSC^SDWLRP3(.RES,DFN)
- IF RES=-1
- SET RESULT(0)=-1
- QUIT
- +4 SET RESULT(0)="<RESULTS>"
- NEW CNT,I
- SET CNT=1
- FOR I=0:0
- SET I=$ORDER(^TMP("SDWLRP3",$JOB,I))
- if 'I
- QUIT
- SET RESULT(CNT)=^(I)
- SET CNT=CNT+1