- CRHD1 ; CAIRO/CLC - ADDED TO WORK WITH HAND OFF TEAM SECTION ;04-Mar-2008 16:00;CLC
- ;;1.0;CRHD;****;Jan 28, 2008;Build 19
- ;=================================================================
- DELENTS(CRHDRTN,CRHDTM,CRHDTY,CRHDP) ;
- ;delete a Hand off patient, provider, or team
- N DA,DIK
- K CRHDRTN
- S CRHDRTN=0
- N CRHDPIEN,CRHDN
- S CRHDN=$S(CRHDTY="P":1,1:2)
- S CRHDPIEN=$O(^CRHD(183.3,+CRHDTM,+CRHDN,"B",+CRHDP,0))
- I CRHDPIEN S DIK="^CRHD(183.3,"_+CRHDTM_","_+CRHDN_",",DA(1)=+CRHDTM,DA=CRHDPIEN D ^DIK S CRHDRTN=1
- Q
- HOTMMGR(CRHDRTN,DUZ) ;
- N CRHDKN,CRHDKEYS,CRHDOUT
- S CRHDRTN=0
- S CRHDKN=$$FIND1^DIC(19.1,"","X","CRHD HOT TEAM MGR","","","OUT")
- D GETS^DIQ(200,DUZ_",","51*","I","CRHDOUT")
- I CRHDKN>0 S CRHDRTN=$D(CRHDOUT(200.051,+CRHDKN_","_DUZ_","))
- Q
- HOTMMEM(CRHDRTN,CRHDTM,CRHDFRM,CRHDDIR,CRHDPFG) ;
- ;Return a set of providers from the HOT Team list.
- ;CRHDPFG - only return providers who have patients assigned to them
- N CRHDPLST,CRHDN,CRHDMAX,CRHDORI,CRHDTL,CRHDPATS
- K CRHDRTN
- S CRHDRTN=""
- I '$G(CRHDDIR) S CRHDDIR=1
- S CRHDORI=0,CRHDMAX=44
- I $G(CRHDPFG) D PP G NX
- D HODLIST^CRHD9(.CRHDPLST,CRHDTM)
- I $D(CRHDPLST) D
- .S CRHDN=0
- .F S CRHDN=$O(CRHDPLST(CRHDN)) Q:'CRHDN D
- ..S CRHDTL($P(CRHDPLST(CRHDN),"^",2))=CRHDPLST(CRHDN)
- NX I CRHDFRM'="",$D(CRHDTL(CRHDFRM)) S CRHDFRM=$E(CRHDFRM,1,$L(CRHDFRM)-1)
- S CRHDN=CRHDFRM
- F Q:CRHDORI'<CRHDMAX S CRHDN=$O(CRHDTL(CRHDN),CRHDDIR) Q:CRHDN="" D
- .S CRHDORI=CRHDORI+1,CRHDRTN(CRHDORI)=CRHDTL(CRHDN)
- Q
- PP ;
- N CRHDPATS,CRHDX
- K CRHDPATS D HOTPRVPT(.CRHDPATS,CRHDTM,"")
- I $D(CRHDPATS) D
- .S CRHDX=0
- .F S CRHDX=$O(CRHDPATS(CRHDX)) Q:'CRHDX D
- ..S:'$D(CRHDTL($P(CRHDPATS(CRHDX),"^",1))) CRHDTL($P(CRHDPATS(CRHDX),"^",1))=$P(CRHDPATS(CRHDX),"^",2)_"^"_$P(CRHDPATS(CRHDX),"^",1)
- Q
- HOTMMEMS(CRHDRTN,CRHDTM,CRHDFRM,CRHDDIR,CRHDCLAS) ;
- ;Return a subset of HO Team list
- ;CRHDCLAS
- ; ATTN:ATTENDING
- ; RES:RESIDENT
- ; INTERN:INTERN
- ; FELLOW:FELLOW
- ; STUD:MED STUDENT
- N CRHDPLST,CRHDN,CRHDMAX,CRHDORI,CRHDTL
- K CRHDRTN
- I '$G(CRHDDIR) S CRHDDIR=1
- S CRHDORI=0,CRHDMAX=44
- D HOTMMEM(.CRHDPLST,CRHDTM,CRHDFRM,CRHDDIR)
- I $D(CRHDPLST) D
- .S CRHDN=0
- .F S CRHDN=$O(CRHDPLST(CRHDN)) Q:'CRHDN D
- ..I $G(CRHDCLAS)'="" I $P(CRHDPLST(CRHDN),"^",3)=CRHDCLAS S CRHDTL($P(CRHDPLST(CRHDN),"^",2))=CRHDPLST(CRHDN)
- ..I $G(CRHDCLAS)="" S CRHDTL($P(CRHDPLST(CRHDN),"^",2))=CRHDPLST(CRHDN)
- F Q:CRHDORI'<CRHDMAX S CRHDN=$O(CRHDTL(CRHDN),CRHDDIR) Q:CRHDN="" D
- .S CRHDORI=CRHDORI+1,CRHDRTN(CRHDORI)=CRHDTL(CRHDN)
- Q
- HOTPRVPT(CRHDRTN,CRHDTM,CRHDPRV) ;
- ;return list of patients from the HO team list provider
- K CRHDRTN
- N CRHDPLST,CRHDORI,CRHDMAX,CRHDP,CRHDTMPL,CRHDCT,CRHDI,CRHDN,CRHDNN,CRHDNNN
- S CRHDORI=0,CRHDMAX=44
- D HOPLIST^CRHD9(.CRHDPLST,CRHDTM)
- I $D(CRHDPLST) D
- .S CRHDN=0,CRHDCT=0
- .F S CRHDN=$O(CRHDPLST(CRHDN)) Q:'CRHDN D
- ..S CRHDP=$P(CRHDPLST(CRHDN),"*",2)
- ..F CRHDI=2:1:$L(CRHDP,";") I +$P(CRHDP,";",CRHDI) D
- ...I +CRHDPRV I +CRHDPRV=+$P(CRHDP,";",CRHDI) S CRHDCT=CRHDCT+1,CRHDTMPL($P($P(CRHDP,";",CRHDI),"^",2),+$P(CRHDP,";",CRHDI),CRHDCT)=$P(CRHDPLST(CRHDN),"*",1) Q
- ...I 'CRHDPRV S CRHDCT=CRHDCT+1,CRHDTMPL($P($P(CRHDP,";",CRHDI),"^",2),+$P(CRHDP,";",CRHDI),CRHDCT)=$P(CRHDPLST(CRHDN),"*",1)
- I $D(CRHDTMPL) D
- .S CRHDN=""
- .F Q:CRHDORI'<CRHDMAX S CRHDN=$O(CRHDTMPL(CRHDN)) Q:CRHDN="" D
- ..S CRHDNN=0
- ..F S CRHDNN=$O(CRHDTMPL(CRHDN,CRHDNN)) Q:'CRHDNN D
- ...S CRHDNNN=0
- ...F S CRHDNNN=$O(CRHDTMPL(CRHDN,CRHDNN,CRHDNNN)) Q:'CRHDNNN D
- ....S CRHDORI=CRHDORI+1,CRHDRTN(CRHDORI)=CRHDN_"^"_CRHDNN_"^"_CRHDTMPL(CRHDN,CRHDNN,CRHDNNN)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HCRHD1 3622 printed Feb 19, 2025@00:04:09 Page 2
- CRHD1 ; CAIRO/CLC - ADDED TO WORK WITH HAND OFF TEAM SECTION ;04-Mar-2008 16:00;CLC
- +1 ;;1.0;CRHD;****;Jan 28, 2008;Build 19
- +2 ;=================================================================
- DELENTS(CRHDRTN,CRHDTM,CRHDTY,CRHDP) ;
- +1 ;delete a Hand off patient, provider, or team
- +2 NEW DA,DIK
- +3 KILL CRHDRTN
- +4 SET CRHDRTN=0
- +5 NEW CRHDPIEN,CRHDN
- +6 SET CRHDN=$SELECT(CRHDTY="P":1,1:2)
- +7 SET CRHDPIEN=$ORDER(^CRHD(183.3,+CRHDTM,+CRHDN,"B",+CRHDP,0))
- +8 IF CRHDPIEN
- SET DIK="^CRHD(183.3,"_+CRHDTM_","_+CRHDN_","
- SET DA(1)=+CRHDTM
- SET DA=CRHDPIEN
- DO ^DIK
- SET CRHDRTN=1
- +9 QUIT
- HOTMMGR(CRHDRTN,DUZ) ;
- +1 NEW CRHDKN,CRHDKEYS,CRHDOUT
- +2 SET CRHDRTN=0
- +3 SET CRHDKN=$$FIND1^DIC(19.1,"","X","CRHD HOT TEAM MGR","","","OUT")
- +4 DO GETS^DIQ(200,DUZ_",","51*","I","CRHDOUT")
- +5 IF CRHDKN>0
- SET CRHDRTN=$DATA(CRHDOUT(200.051,+CRHDKN_","_DUZ_","))
- +6 QUIT
- HOTMMEM(CRHDRTN,CRHDTM,CRHDFRM,CRHDDIR,CRHDPFG) ;
- +1 ;Return a set of providers from the HOT Team list.
- +2 ;CRHDPFG - only return providers who have patients assigned to them
- +3 NEW CRHDPLST,CRHDN,CRHDMAX,CRHDORI,CRHDTL,CRHDPATS
- +4 KILL CRHDRTN
- +5 SET CRHDRTN=""
- +6 IF '$GET(CRHDDIR)
- SET CRHDDIR=1
- +7 SET CRHDORI=0
- SET CRHDMAX=44
- +8 IF $GET(CRHDPFG)
- DO PP
- GOTO NX
- +9 DO HODLIST^CRHD9(.CRHDPLST,CRHDTM)
- +10 IF $DATA(CRHDPLST)
- Begin DoDot:1
- +11 SET CRHDN=0
- +12 FOR
- SET CRHDN=$ORDER(CRHDPLST(CRHDN))
- if 'CRHDN
- QUIT
- Begin DoDot:2
- +13 SET CRHDTL($PIECE(CRHDPLST(CRHDN),"^",2))=CRHDPLST(CRHDN)
- End DoDot:2
- End DoDot:1
- NX IF CRHDFRM'=""
- IF $DATA(CRHDTL(CRHDFRM))
- SET CRHDFRM=$EXTRACT(CRHDFRM,1,$LENGTH(CRHDFRM)-1)
- +1 SET CRHDN=CRHDFRM
- +2 FOR
- if CRHDORI'<CRHDMAX
- QUIT
- SET CRHDN=$ORDER(CRHDTL(CRHDN),CRHDDIR)
- if CRHDN=""
- QUIT
- Begin DoDot:1
- +3 SET CRHDORI=CRHDORI+1
- SET CRHDRTN(CRHDORI)=CRHDTL(CRHDN)
- End DoDot:1
- +4 QUIT
- PP ;
- +1 NEW CRHDPATS,CRHDX
- +2 KILL CRHDPATS
- DO HOTPRVPT(.CRHDPATS,CRHDTM,"")
- +3 IF $DATA(CRHDPATS)
- Begin DoDot:1
- +4 SET CRHDX=0
- +5 FOR
- SET CRHDX=$ORDER(CRHDPATS(CRHDX))
- if 'CRHDX
- QUIT
- Begin DoDot:2
- +6 if '$DATA(CRHDTL($PIECE(CRHDPATS(CRHDX),"^",1)))
- SET CRHDTL($PIECE(CRHDPATS(CRHDX),"^",1))=$PIECE(CRHDPATS(CRHDX),"^",2)_"^"_$PIECE(CRHDPATS(CRHDX),"^",1)
- End DoDot:2
- End DoDot:1
- +7 QUIT
- HOTMMEMS(CRHDRTN,CRHDTM,CRHDFRM,CRHDDIR,CRHDCLAS) ;
- +1 ;Return a subset of HO Team list
- +2 ;CRHDCLAS
- +3 ; ATTN:ATTENDING
- +4 ; RES:RESIDENT
- +5 ; INTERN:INTERN
- +6 ; FELLOW:FELLOW
- +7 ; STUD:MED STUDENT
- +8 NEW CRHDPLST,CRHDN,CRHDMAX,CRHDORI,CRHDTL
- +9 KILL CRHDRTN
- +10 IF '$GET(CRHDDIR)
- SET CRHDDIR=1
- +11 SET CRHDORI=0
- SET CRHDMAX=44
- +12 DO HOTMMEM(.CRHDPLST,CRHDTM,CRHDFRM,CRHDDIR)
- +13 IF $DATA(CRHDPLST)
- Begin DoDot:1
- +14 SET CRHDN=0
- +15 FOR
- SET CRHDN=$ORDER(CRHDPLST(CRHDN))
- if 'CRHDN
- QUIT
- Begin DoDot:2
- +16 IF $GET(CRHDCLAS)'=""
- IF $PIECE(CRHDPLST(CRHDN),"^",3)=CRHDCLAS
- SET CRHDTL($PIECE(CRHDPLST(CRHDN),"^",2))=CRHDPLST(CRHDN)
- +17 IF $GET(CRHDCLAS)=""
- SET CRHDTL($PIECE(CRHDPLST(CRHDN),"^",2))=CRHDPLST(CRHDN)
- End DoDot:2
- End DoDot:1
- +18 FOR
- if CRHDORI'<CRHDMAX
- QUIT
- SET CRHDN=$ORDER(CRHDTL(CRHDN),CRHDDIR)
- if CRHDN=""
- QUIT
- Begin DoDot:1
- +19 SET CRHDORI=CRHDORI+1
- SET CRHDRTN(CRHDORI)=CRHDTL(CRHDN)
- End DoDot:1
- +20 QUIT
- HOTPRVPT(CRHDRTN,CRHDTM,CRHDPRV) ;
- +1 ;return list of patients from the HO team list provider
- +2 KILL CRHDRTN
- +3 NEW CRHDPLST,CRHDORI,CRHDMAX,CRHDP,CRHDTMPL,CRHDCT,CRHDI,CRHDN,CRHDNN,CRHDNNN
- +4 SET CRHDORI=0
- SET CRHDMAX=44
- +5 DO HOPLIST^CRHD9(.CRHDPLST,CRHDTM)
- +6 IF $DATA(CRHDPLST)
- Begin DoDot:1
- +7 SET CRHDN=0
- SET CRHDCT=0
- +8 FOR
- SET CRHDN=$ORDER(CRHDPLST(CRHDN))
- if 'CRHDN
- QUIT
- Begin DoDot:2
- +9 SET CRHDP=$PIECE(CRHDPLST(CRHDN),"*",2)
- +10 FOR CRHDI=2:1:$LENGTH(CRHDP,";")
- IF +$PIECE(CRHDP,";",CRHDI)
- Begin DoDot:3
- +11 IF +CRHDPRV
- IF +CRHDPRV=+$PIECE(CRHDP,";",CRHDI)
- SET CRHDCT=CRHDCT+1
- SET CRHDTMPL($PIECE($PIECE(CRHDP,";",CRHDI),"^",2),+$PIECE(CRHDP,";",CRHDI),CRHDCT)=$PIECE(CRHDPLST(CRHDN),"*",1)
- QUIT
- +12 IF 'CRHDPRV
- SET CRHDCT=CRHDCT+1
- SET CRHDTMPL($PIECE($PIECE(CRHDP,";",CRHDI),"^",2),+$PIECE(CRHDP,";",CRHDI),CRHDCT)=$PIECE(CRHDPLST(CRHDN),"*",1)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 IF $DATA(CRHDTMPL)
- Begin DoDot:1
- +14 SET CRHDN=""
- +15 FOR
- if CRHDORI'<CRHDMAX
- QUIT
- SET CRHDN=$ORDER(CRHDTMPL(CRHDN))
- if CRHDN=""
- QUIT
- Begin DoDot:2
- +16 SET CRHDNN=0
- +17 FOR
- SET CRHDNN=$ORDER(CRHDTMPL(CRHDN,CRHDNN))
- if 'CRHDNN
- QUIT
- Begin DoDot:3
- +18 SET CRHDNNN=0
- +19 FOR
- SET CRHDNNN=$ORDER(CRHDTMPL(CRHDN,CRHDNN,CRHDNNN))
- if 'CRHDNNN
- QUIT
- Begin DoDot:4
- +20 SET CRHDORI=CRHDORI+1
- SET CRHDRTN(CRHDORI)=CRHDN_"^"_CRHDNN_"^"_CRHDTMPL(CRHDN,CRHDNN,CRHDNNN)
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT