- SCAPMC8P ;bp/cmf - preceptor sub-array for practitioner list ; 8/10/99 1:19pm
- ;;5.3;Scheduling;**177,212**;AUG 13, 1993
- ;;1.0
- ;
- PRCTP ; preceptor practitioners for position
- ;
- ST N SCDATES1,SCN1,SCEFF1,SCPAH1,SCACT1,SCINDT1,SCNODE1,SCPRTP1
- N SCDATES2,SCN2,SCPTP,SCX,SCXA,SCXE,SCNA,SCNE,SCPRCLST,SCPRCPTR
- N SCP1P11,SCP12,SCP13,SCP14P16,SCR
- N SCLIST1,SCLIST2,SCN3,SCN4,SCPS,SCPSX,SCPSXA,SCPSXE,SCVALHIS
- ;
- S @SCLIST@("PR","CH")=$$VALHIST^SCAPMCU5(404.53,SCTP,"SCVALHIS")
- G:'$$ACTHIST^SCAPMCU5("SCVALHIS","SCDATES") PRECQ
- G:'$D(SCVALHIS) PRECQ
- ;
- LOOP1 ; build list of preceptor assignments
- S SCEFF1=-(SCEND+.000001)
- S (SCN1,SCLIST1(0))=0
- F S SCEFF1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1)) Q:'SCEFF1 D
- . ;Q:'$$ACTHIST^SCAPMCU2(404.53,SCTP,SCDATES,.SCERR,"SCPRTP1")
- . S SCPAH1=""
- . F S SCPAH1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1,SCPAH1),-1) Q:'SCPAH1 D
- . . Q:'$D(SCVALHIS("I",SCPAH1))
- . . N SCACT1,SCI
- . . S SCNODE1=^SCTM(404.53,SCPAH1,0)
- . . S SCI=$O(SCVALHIS("I",SCPAH1,0))
- . . S SCACT1=$O(SCVALHIS(SCI,0))
- . . S SCPTP=+$P(SCNODE1,U,6)
- . . Q:$D(SCLIST1("SCPR",SCACT1,SCPTP))
- . . S SCINDT1=$P(SCVALHIS(SCI,SCACT1,SCPAH1),U)
- . . Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT1,SCINDT1)
- . . S SCN1=SCN1+1
- . . S SCLIST1(0)=SCN1
- . . S SCLIST1(SCN1)=SCPTP_U_SCACT1_U_SCINDT1_U_SCPAH1
- . . S SCLIST1("SCPR",SCACT1,SCPTP,SCN1)=""
- . . Q
- . Q
- ;
- LOOP2 ; get preceptors for preceptor assignments
- G:SCLIST1(0)<1 PRECQ
- S SCLIST2(0)=SCLIST1(0)
- F SCN2=1:1:SCLIST2(0) D
- . S SCX=SCLIST1(SCN2)
- . ; bp/cmf 212 begin
- . ; OLD CODE BELOW
- . ;S SCPTP=$P(SCX,U)
- . ;K SCPRCLST
- . ;Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES","SCPRCLST",SCERR,0)
- . ; OLD CODE ABOVE
- . ; NEW CODE BELOW
- . S SCPTP=$P(SCX,U)
- . S SCDATES1("BEGIN")=$P(SCX,U,2)
- . S SCDATES1("END")=$P(SCX,U,3)
- . S SCDATES1("INCL")=0
- . K SCPRCLST
- . Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES1","SCPRCLST",SCERR,0)
- . ; NEW CODE ABOVE
- . ; bp/cmf 212 end
- . Q:'$D(SCPRCLST(0))
- . S SCLIST2(SCN2,0)=SCPRCLST(0)
- . F SCN3=1:1:SCPRCLST(0) D
- . . S SCLIST2(SCN2,SCN3)=SCPRCLST(SCN3)
- . Q
- ;
- LOOP3 ; add preceptor sub-array to sclist
- G:SCLIST2(0)<1 PRECQ
- F SCN1=1:1:@SCLIST@(0) D
- . S SCXA=$P(@SCLIST@(SCN1),U,9) ;asgn actdt
- . S SCXE=$P(@SCLIST@(SCN1),U,10)
- . S SCXE=$S(+SCXE:SCXE,1:9999999) ;asgn enddt
- . S SCNA=SCXE
- . S SCN4=0
- . F S SCNA=$O(SCLIST1("SCPR",SCNA),-1) Q:'SCNA D ;prec actdt
- . . S SCPTP=$O(SCLIST1("SCPR",SCNA,0)) ;prec tpien
- . . S SCN2=$O(SCLIST1("SCPR",SCNA,SCPTP,0))
- . . Q:'$D(SCLIST2(SCN2))
- . . S SCP14P16=$P(SCLIST1(SCN2),U,2,4) ;prec string
- . . S SCNE=$P(SCLIST1(SCN2),U,3)
- . . S SCNE=$S(+SCNE:SCNE,1:9999999) ;prec enddt
- . . Q:SCNE<SCXA
- . . F SCN3=1:1:SCLIST2(SCN2,0) D
- . . . ; bp/cmf 212 begin
- . . . ; old code below
- . . . ;S SCN4=SCN4+1
- . . . ;S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
- . . . ;S SCP1P11=$P(SCPSX,U,1,11) ;pos string
- . . . ;S SCP12=$P(SCPSX,U,12) ;should be ""
- . . . ;S SCP13=$P(SCPSX,U,13) ;should be ""
- . . . ;S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
- . . . ; old code above
- . . . ; new code below
- . . . S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
- . . . Q:'$$DTCHK^SCAPU1(SCXA,SCXE,0,$P(SCPSX,U,9),$P(SCPSX,U,10))
- . . . S SCN4=SCN4+1
- . . . S SCP1P11=$P(SCPSX,U,1,11) ;pos string
- . . . S SCP12=$P(SCPSX,U,12) ;should be ""
- . . . S SCP13=$P(SCPSX,U,13) ;should be ""
- . . . S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
- . . . ; new code above
- . . . ; bp/cmf 212 end
- . . . S @SCLIST@(SCN1,"PR",SCN4)=SCR
- . . . S @SCLIST@(SCN1,"PR",0)=SCN4
- . . . S @SCLIST@(SCN1,"SCPR",$P(SCR,U),$P(SCR,U,3),$P(SCR,U,14),SCN4)=""
- . . . Q
- . . Q
- . Q
- ;
- PRECQ I +SCALLHIS D TPALL^SCAPMC8A(404.53)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC8P 4074 printed Feb 19, 2025@00:04:42 Page 2
- SCAPMC8P ;bp/cmf - preceptor sub-array for practitioner list ; 8/10/99 1:19pm
- +1 ;;5.3;Scheduling;**177,212**;AUG 13, 1993
- +2 ;;1.0
- +3 ;
- PRCTP ; preceptor practitioners for position
- +1 ;
- ST NEW SCDATES1,SCN1,SCEFF1,SCPAH1,SCACT1,SCINDT1,SCNODE1,SCPRTP1
- +1 NEW SCDATES2,SCN2,SCPTP,SCX,SCXA,SCXE,SCNA,SCNE,SCPRCLST,SCPRCPTR
- +2 NEW SCP1P11,SCP12,SCP13,SCP14P16,SCR
- +3 NEW SCLIST1,SCLIST2,SCN3,SCN4,SCPS,SCPSX,SCPSXA,SCPSXE,SCVALHIS
- +4 ;
- +5 SET @SCLIST@("PR","CH")=$$VALHIST^SCAPMCU5(404.53,SCTP,"SCVALHIS")
- +6 if '$$ACTHIST^SCAPMCU5("SCVALHIS","SCDATES")
- GOTO PRECQ
- +7 if '$DATA(SCVALHIS)
- GOTO PRECQ
- +8 ;
- LOOP1 ; build list of preceptor assignments
- +1 SET SCEFF1=-(SCEND+.000001)
- +2 SET (SCN1,SCLIST1(0))=0
- +3 FOR
- SET SCEFF1=$ORDER(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1))
- if 'SCEFF1
- QUIT
- Begin DoDot:1
- +4 ;Q:'$$ACTHIST^SCAPMCU2(404.53,SCTP,SCDATES,.SCERR,"SCPRTP1")
- +5 SET SCPAH1=""
- +6 FOR
- SET SCPAH1=$ORDER(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1,SCPAH1),-1)
- if 'SCPAH1
- QUIT
- Begin DoDot:2
- +7 if '$DATA(SCVALHIS("I",SCPAH1))
- QUIT
- +8 NEW SCACT1,SCI
- +9 SET SCNODE1=^SCTM(404.53,SCPAH1,0)
- +10 SET SCI=$ORDER(SCVALHIS("I",SCPAH1,0))
- +11 SET SCACT1=$ORDER(SCVALHIS(SCI,0))
- +12 SET SCPTP=+$PIECE(SCNODE1,U,6)
- +13 if $DATA(SCLIST1("SCPR",SCACT1,SCPTP))
- QUIT
- +14 SET SCINDT1=$PIECE(SCVALHIS(SCI,SCACT1,SCPAH1),U)
- +15 if '$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT1,SCINDT1)
- QUIT
- +16 SET SCN1=SCN1+1
- +17 SET SCLIST1(0)=SCN1
- +18 SET SCLIST1(SCN1)=SCPTP_U_SCACT1_U_SCINDT1_U_SCPAH1
- +19 SET SCLIST1("SCPR",SCACT1,SCPTP,SCN1)=""
- +20 QUIT
- End DoDot:2
- +21 QUIT
- End DoDot:1
- +22 ;
- LOOP2 ; get preceptors for preceptor assignments
- +1 if SCLIST1(0)<1
- GOTO PRECQ
- +2 SET SCLIST2(0)=SCLIST1(0)
- +3 FOR SCN2=1:1:SCLIST2(0)
- Begin DoDot:1
- +4 SET SCX=SCLIST1(SCN2)
- +5 ; bp/cmf 212 begin
- +6 ; OLD CODE BELOW
- +7 ;S SCPTP=$P(SCX,U)
- +8 ;K SCPRCLST
- +9 ;Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES","SCPRCLST",SCERR,0)
- +10 ; OLD CODE ABOVE
- +11 ; NEW CODE BELOW
- +12 SET SCPTP=$PIECE(SCX,U)
- +13 SET SCDATES1("BEGIN")=$PIECE(SCX,U,2)
- +14 SET SCDATES1("END")=$PIECE(SCX,U,3)
- +15 SET SCDATES1("INCL")=0
- +16 KILL SCPRCLST
- +17 if '$$PRTP^SCAPMC8(SCPTP,"SCDATES1","SCPRCLST",SCERR,0)
- QUIT
- +18 ; NEW CODE ABOVE
- +19 ; bp/cmf 212 end
- +20 if '$DATA(SCPRCLST(0))
- QUIT
- +21 SET SCLIST2(SCN2,0)=SCPRCLST(0)
- +22 FOR SCN3=1:1:SCPRCLST(0)
- Begin DoDot:2
- +23 SET SCLIST2(SCN2,SCN3)=SCPRCLST(SCN3)
- End DoDot:2
- +24 QUIT
- End DoDot:1
- +25 ;
- LOOP3 ; add preceptor sub-array to sclist
- +1 if SCLIST2(0)<1
- GOTO PRECQ
- +2 FOR SCN1=1:1:@SCLIST@(0)
- Begin DoDot:1
- +3 ;asgn actdt
- SET SCXA=$PIECE(@SCLIST@(SCN1),U,9)
- +4 SET SCXE=$PIECE(@SCLIST@(SCN1),U,10)
- +5 ;asgn enddt
- SET SCXE=$SELECT(+SCXE:SCXE,1:9999999)
- +6 SET SCNA=SCXE
- +7 SET SCN4=0
- +8 ;prec actdt
- FOR
- SET SCNA=$ORDER(SCLIST1("SCPR",SCNA),-1)
- if 'SCNA
- QUIT
- Begin DoDot:2
- +9 ;prec tpien
- SET SCPTP=$ORDER(SCLIST1("SCPR",SCNA,0))
- +10 SET SCN2=$ORDER(SCLIST1("SCPR",SCNA,SCPTP,0))
- +11 if '$DATA(SCLIST2(SCN2))
- QUIT
- +12 ;prec string
- SET SCP14P16=$PIECE(SCLIST1(SCN2),U,2,4)
- +13 SET SCNE=$PIECE(SCLIST1(SCN2),U,3)
- +14 ;prec enddt
- SET SCNE=$SELECT(+SCNE:SCNE,1:9999999)
- +15 if SCNE<SCXA
- QUIT
- +16 FOR SCN3=1:1:SCLIST2(SCN2,0)
- Begin DoDot:3
- +17 ; bp/cmf 212 begin
- +18 ; old code below
- +19 ;S SCN4=SCN4+1
- +20 ;S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
- +21 ;S SCP1P11=$P(SCPSX,U,1,11) ;pos string
- +22 ;S SCP12=$P(SCPSX,U,12) ;should be ""
- +23 ;S SCP13=$P(SCPSX,U,13) ;should be ""
- +24 ;S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
- +25 ; old code above
- +26 ; new code below
- +27 ;asgn string
- SET SCPSX=SCLIST2(SCN2,SCN3)
- +28 if '$$DTCHK^SCAPU1(SCXA,SCXE,0,$PIECE(SCPSX,U,9),$PIECE(SCPSX,U,10))
- QUIT
- +29 SET SCN4=SCN4+1
- +30 ;pos string
- SET SCP1P11=$PIECE(SCPSX,U,1,11)
- +31 ;should be ""
- SET SCP12=$PIECE(SCPSX,U,12)
- +32 ;should be ""
- SET SCP13=$PIECE(SCPSX,U,13)
- +33 ;rtrn string
- SET SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16
- +34 ; new code above
- +35 ; bp/cmf 212 end
- +36 SET @SCLIST@(SCN1,"PR",SCN4)=SCR
- +37 SET @SCLIST@(SCN1,"PR",0)=SCN4
- +38 SET @SCLIST@(SCN1,"SCPR",$PIECE(SCR,U),$PIECE(SCR,U,3),$PIECE(SCR,U,14),SCN4)=""
- +39 QUIT
- End DoDot:3
- +40 QUIT
- End DoDot:2
- +41 QUIT
- End DoDot:1
- +42 ;
- PRECQ IF +SCALLHIS
- DO TPALL^SCAPMC8A(404.53)
- +1 QUIT
- +2 ;