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 Dec 13, 2024@02:38:12 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 ;
