Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SCAPMC8P

SCAPMC8P.m

Go to the documentation of this file.
  1. SCAPMC8P ;bp/cmf - preceptor sub-array for practitioner list ; 8/10/99 1:19pm
  1. ;;5.3;Scheduling;**177,212**;AUG 13, 1993
  1. ;;1.0
  1. ;
  1. PRCTP ; preceptor practitioners for position
  1. ;
  1. ST N SCDATES1,SCN1,SCEFF1,SCPAH1,SCACT1,SCINDT1,SCNODE1,SCPRTP1
  1. N SCDATES2,SCN2,SCPTP,SCX,SCXA,SCXE,SCNA,SCNE,SCPRCLST,SCPRCPTR
  1. N SCP1P11,SCP12,SCP13,SCP14P16,SCR
  1. N SCLIST1,SCLIST2,SCN3,SCN4,SCPS,SCPSX,SCPSXA,SCPSXE,SCVALHIS
  1. ;
  1. S @SCLIST@("PR","CH")=$$VALHIST^SCAPMCU5(404.53,SCTP,"SCVALHIS")
  1. G:'$$ACTHIST^SCAPMCU5("SCVALHIS","SCDATES") PRECQ
  1. G:'$D(SCVALHIS) PRECQ
  1. ;
  1. LOOP1 ; build list of preceptor assignments
  1. S SCEFF1=-(SCEND+.000001)
  1. S (SCN1,SCLIST1(0))=0
  1. F S SCEFF1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1)) Q:'SCEFF1 D
  1. . ;Q:'$$ACTHIST^SCAPMCU2(404.53,SCTP,SCDATES,.SCERR,"SCPRTP1")
  1. . S SCPAH1=""
  1. . F S SCPAH1=$O(^SCTM(404.53,"AIDT",SCTP,1,SCEFF1,SCPAH1),-1) Q:'SCPAH1 D
  1. . . Q:'$D(SCVALHIS("I",SCPAH1))
  1. . . N SCACT1,SCI
  1. . . S SCNODE1=^SCTM(404.53,SCPAH1,0)
  1. . . S SCI=$O(SCVALHIS("I",SCPAH1,0))
  1. . . S SCACT1=$O(SCVALHIS(SCI,0))
  1. . . S SCPTP=+$P(SCNODE1,U,6)
  1. . . Q:$D(SCLIST1("SCPR",SCACT1,SCPTP))
  1. . . S SCINDT1=$P(SCVALHIS(SCI,SCACT1,SCPAH1),U)
  1. . . Q:'$$DTCHK^SCAPU1(SCBEGIN,SCEND,SCINCL,SCACT1,SCINDT1)
  1. . . S SCN1=SCN1+1
  1. . . S SCLIST1(0)=SCN1
  1. . . S SCLIST1(SCN1)=SCPTP_U_SCACT1_U_SCINDT1_U_SCPAH1
  1. . . S SCLIST1("SCPR",SCACT1,SCPTP,SCN1)=""
  1. . . Q
  1. . Q
  1. ;
  1. LOOP2 ; get preceptors for preceptor assignments
  1. G:SCLIST1(0)<1 PRECQ
  1. S SCLIST2(0)=SCLIST1(0)
  1. F SCN2=1:1:SCLIST2(0) D
  1. . S SCX=SCLIST1(SCN2)
  1. . ; bp/cmf 212 begin
  1. . ; OLD CODE BELOW
  1. . ;S SCPTP=$P(SCX,U)
  1. . ;K SCPRCLST
  1. . ;Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES","SCPRCLST",SCERR,0)
  1. . ; OLD CODE ABOVE
  1. . ; NEW CODE BELOW
  1. . S SCPTP=$P(SCX,U)
  1. . S SCDATES1("BEGIN")=$P(SCX,U,2)
  1. . S SCDATES1("END")=$P(SCX,U,3)
  1. . S SCDATES1("INCL")=0
  1. . K SCPRCLST
  1. . Q:'$$PRTP^SCAPMC8(SCPTP,"SCDATES1","SCPRCLST",SCERR,0)
  1. . ; NEW CODE ABOVE
  1. . ; bp/cmf 212 end
  1. . Q:'$D(SCPRCLST(0))
  1. . S SCLIST2(SCN2,0)=SCPRCLST(0)
  1. . F SCN3=1:1:SCPRCLST(0) D
  1. . . S SCLIST2(SCN2,SCN3)=SCPRCLST(SCN3)
  1. . Q
  1. ;
  1. LOOP3 ; add preceptor sub-array to sclist
  1. G:SCLIST2(0)<1 PRECQ
  1. F SCN1=1:1:@SCLIST@(0) D
  1. . S SCXA=$P(@SCLIST@(SCN1),U,9) ;asgn actdt
  1. . S SCXE=$P(@SCLIST@(SCN1),U,10)
  1. . S SCXE=$S(+SCXE:SCXE,1:9999999) ;asgn enddt
  1. . S SCNA=SCXE
  1. . S SCN4=0
  1. . F S SCNA=$O(SCLIST1("SCPR",SCNA),-1) Q:'SCNA D ;prec actdt
  1. . . S SCPTP=$O(SCLIST1("SCPR",SCNA,0)) ;prec tpien
  1. . . S SCN2=$O(SCLIST1("SCPR",SCNA,SCPTP,0))
  1. . . Q:'$D(SCLIST2(SCN2))
  1. . . S SCP14P16=$P(SCLIST1(SCN2),U,2,4) ;prec string
  1. . . S SCNE=$P(SCLIST1(SCN2),U,3)
  1. . . S SCNE=$S(+SCNE:SCNE,1:9999999) ;prec enddt
  1. . . Q:SCNE<SCXA
  1. . . F SCN3=1:1:SCLIST2(SCN2,0) D
  1. . . . ; bp/cmf 212 begin
  1. . . . ; old code below
  1. . . . ;S SCN4=SCN4+1
  1. . . . ;S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
  1. . . . ;S SCP1P11=$P(SCPSX,U,1,11) ;pos string
  1. . . . ;S SCP12=$P(SCPSX,U,12) ;should be ""
  1. . . . ;S SCP13=$P(SCPSX,U,13) ;should be ""
  1. . . . ;S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
  1. . . . ; old code above
  1. . . . ; new code below
  1. . . . S SCPSX=SCLIST2(SCN2,SCN3) ;asgn string
  1. . . . Q:'$$DTCHK^SCAPU1(SCXA,SCXE,0,$P(SCPSX,U,9),$P(SCPSX,U,10))
  1. . . . S SCN4=SCN4+1
  1. . . . S SCP1P11=$P(SCPSX,U,1,11) ;pos string
  1. . . . S SCP12=$P(SCPSX,U,12) ;should be ""
  1. . . . S SCP13=$P(SCPSX,U,13) ;should be ""
  1. . . . S SCR=SCP1P11_U_SCP12_U_SCP13_U_SCP14P16 ;rtrn string
  1. . . . ; new code above
  1. . . . ; bp/cmf 212 end
  1. . . . S @SCLIST@(SCN1,"PR",SCN4)=SCR
  1. . . . S @SCLIST@(SCN1,"PR",0)=SCN4
  1. . . . S @SCLIST@(SCN1,"SCPR",$P(SCR,U),$P(SCR,U,3),$P(SCR,U,14),SCN4)=""
  1. . . . Q
  1. . . Q
  1. . Q
  1. ;
  1. PRECQ I +SCALLHIS D TPALL^SCAPMC8A(404.53)
  1. Q
  1. ;