- SCAPMC8A ;bp/cmf - Build "ALL" array for $$PRTP^SCAPCM8 ;13 June 1999
- ;;5.3;Scheduling;**177,204**;AUG 13, 1993
- ;
- TPALL(SCFILE) ;
- N SCD1,SCD0,SCAN,SCX,SCIEN,SCFLD
- N SCP1,SCP2,SCP3,SCP4,SCP5,SCP6,SCP7
- ;
- G:'$D(^SCTM(SCFILE,"B",SCTP)) TPQUIT
- S SCD1=@SCDATES@("BEGIN") ;begin date range
- S SCD0=@SCDATES@("END") ;end date range
- ;
- LOOP S SCAN=0 ;incrementor
- S SCP7=0 ;pos asgn ien
- F S SCP7=$O(^SCTM(SCFILE,"B",SCTP,SCP7)) Q:'SCP7 D
- . N SCX,SCP1,SCP2,SCP3,SCP4,SCP5,SCP6
- . Q:'$D(^SCTM(SCFILE,SCP7,0))
- . S SCIEN=SCP7_","
- . S SCFLD=$S(SCFILE=404.52:".02;.03;.04",1:".02;.04;.06")
- . D GETS^DIQ(SCFILE,SCIEN,SCFLD,"IE","SCX")
- . Q:'$D(SCX)
- . S SCP3=$G(SCX(SCFILE,SCIEN,.02,"I")) ;pos asgn date int
- . Q:(SCP3<SCD1)!(SCP3>SCD0)
- . S SCAN=SCAN+1
- . S SCP1=$G(SCX(SCFILE,SCIEN,.04,"I")) ;status int code
- . S SCP2=$G(SCX(SCFILE,SCIEN,.04,"E")) ;status ext form
- . S SCP4=$G(SCX(SCFILE,SCIEN,.02,"E")) ;pos asgn date ext
- . D:SCFILE=404.52
- . . S SCP5=$G(SCX(SCFILE,SCIEN,.03,"I")) ;practition ien
- . . S SCP6=$G(SCX(SCFILE,SCIEN,.03,"E")) ;practitioner name
- . . Q
- . D:SCFILE=404.53
- . . S SCP5=$G(SCX(SCFILE,SCIEN,.06,"I")) ;precept posn ien
- . . S SCP6=$G(SCX(SCFILE,SCIEN,.06,"E")) ;precept posn name
- . . Q
- . S @SCLIST@("ALL",SCFILE,0)=SCAN
- . S @SCLIST@("ALL",SCFILE,SCAN)=SCP1_U_SCP2_U_SCP3_U_SCP4_U_SCP5_U_SCP6_U_SCP7
- ;
- TPQUIT Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC8A 1554 printed Feb 19, 2025@00:04:40 Page 2
- SCAPMC8A ;bp/cmf - Build "ALL" array for $$PRTP^SCAPCM8 ;13 June 1999
- +1 ;;5.3;Scheduling;**177,204**;AUG 13, 1993
- +2 ;
- TPALL(SCFILE) ;
- +1 NEW SCD1,SCD0,SCAN,SCX,SCIEN,SCFLD
- +2 NEW SCP1,SCP2,SCP3,SCP4,SCP5,SCP6,SCP7
- +3 ;
- +4 if '$DATA(^SCTM(SCFILE,"B",SCTP))
- GOTO TPQUIT
- +5 ;begin date range
- SET SCD1=@SCDATES@("BEGIN")
- +6 ;end date range
- SET SCD0=@SCDATES@("END")
- +7 ;
- LOOP ;incrementor
- SET SCAN=0
- +1 ;pos asgn ien
- SET SCP7=0
- +2 FOR
- SET SCP7=$ORDER(^SCTM(SCFILE,"B",SCTP,SCP7))
- if 'SCP7
- QUIT
- Begin DoDot:1
- +3 NEW SCX,SCP1,SCP2,SCP3,SCP4,SCP5,SCP6
- +4 if '$DATA(^SCTM(SCFILE,SCP7,0))
- QUIT
- +5 SET SCIEN=SCP7_","
- +6 SET SCFLD=$SELECT(SCFILE=404.52:".02;.03;.04",1:".02;.04;.06")
- +7 DO GETS^DIQ(SCFILE,SCIEN,SCFLD,"IE","SCX")
- +8 if '$DATA(SCX)
- QUIT
- +9 ;pos asgn date int
- SET SCP3=$GET(SCX(SCFILE,SCIEN,.02,"I"))
- +10 if (SCP3<SCD1)!(SCP3>SCD0)
- QUIT
- +11 SET SCAN=SCAN+1
- +12 ;status int code
- SET SCP1=$GET(SCX(SCFILE,SCIEN,.04,"I"))
- +13 ;status ext form
- SET SCP2=$GET(SCX(SCFILE,SCIEN,.04,"E"))
- +14 ;pos asgn date ext
- SET SCP4=$GET(SCX(SCFILE,SCIEN,.02,"E"))
- +15 if SCFILE=404.52
- Begin DoDot:2
- +16 ;practition ien
- SET SCP5=$GET(SCX(SCFILE,SCIEN,.03,"I"))
- +17 ;practitioner name
- SET SCP6=$GET(SCX(SCFILE,SCIEN,.03,"E"))
- +18 QUIT
- End DoDot:2
- +19 if SCFILE=404.53
- Begin DoDot:2
- +20 ;precept posn ien
- SET SCP5=$GET(SCX(SCFILE,SCIEN,.06,"I"))
- +21 ;precept posn name
- SET SCP6=$GET(SCX(SCFILE,SCIEN,.06,"E"))
- +22 QUIT
- End DoDot:2
- +23 SET @SCLIST@("ALL",SCFILE,0)=SCAN
- +24 SET @SCLIST@("ALL",SCFILE,SCAN)=SCP1_U_SCP2_U_SCP3_U_SCP4_U_SCP5_U_SCP6_U_SCP7
- End DoDot:1
- +25 ;
- TPQUIT QUIT
- +1 ;