- SCAPMC24 ;ALB/REW - Team API's:TPTM ; 27 Jun 99 3:05 PM
- ;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
- ;;1.0
- TPTM(SCTM,SCDATES,SCUSRA,SCROLEA,SCLIST,SCERR) ; -- positions for a pract
- ; input:
- ; SCTM = ien of TEAM File (#404.51) [required]
- ; SCDATES("BEGIN") = begin date to search (inclusive)
- ; [default: TODAY]
- ; ("END") = end date to search (inclusive)
- ; [default: TODAY]
- ; ("INCL") = 1: only use patients who were assigned to
- ; team for entire date range
- ; 0: anytime in date range
- ; [default: 1]
- ; SCUSRA -array of pointers to user file - 8930
- ; if none are defined - returns all usr classes
- ; if @SCPURPA@('exclude') is defined - exclude listed usr class
- ; SCROLEA - array of pointers to std position file 403.46 (per scusra)
- ; SCLIST -array name to store list
- ; [ex. ^TMP("SCPT",$J)]
- ;
- ; SCERR = array NAME to store error messages.
- ; [ex. ^TMP("ORXX",$J)]
- ;
- ; Output:
- ; SCLIST() = array of positions (includes SCTP xref)
- ; Format:
- ; Subscript: Sequential # from 1 to n
- ; Piece Description
- ; 1 IEN of TEAM POSITION File (#404.57)
- ; 2 Name of Position
- ; 3 IEN of Team #404.51
- ; 4 IEN of file #404.59 (Tm Pos History)
- ; 5 current effective date
- ; 6 current inactivate date (if any)
- ; 7 pointer to 403.46 (role)
- ; 8 Name of Standard Role
- ; 9 pointer to User Class (#8930)
- ; 10 Name of User Class
- ; Subscript: "SCTP",SCTM,IEN =""
- ;
- ; SCERR() = Array of DIALOG file messages(errors) .
- ; @SCERR@(0) = number of errors, undefined if none
- ; Format:
- ; Subscript: Sequential # from 1 to n
- ; Piece Description
- ; 1 IEN of DIALOG file
- ; Returned: 1 if ok, 0 if error
- ; Other:
- ; SCACTHIS = status (-1:err|0:inact|1:act)^404.59 ien ^actdt^inacdt
- ;
- ;
- ST N SCPTTP,SCPTTP0,SCTP,SCR,SCACTHIS,SCND,SCTPTM,SCTPA
- N SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS
- ; -- initialize control variables
- G:'$$OKDATA PRACQ
- ; -- loop through team positionS
- S (SCTP,SCTPA)=0
- F S SCTP=$O(^SCTM(404.57,"C",SCTM,SCTP)) Q:'SCTP Q:'$$TPVALBLD(SCTP,.SCDATES,.SCPOSA,.SCUSA,.SCPURPA,.SCROLEA,.SCLIST,.SCERR)
- PRACQ Q $G(@SCERR@(0))<1
- ;
- TPVALBLD(SCTP,SCDATES,SCPOSA,SCUSA,SCPURPA,SCROLEA,SCLIST,SCERR) ;
- ; this validates a team position & builds sclist array
- ; returns 1 if ok, 0 if error
- N SCTPDT,SCDDDD,SCTP0,SCU,SCR,SCTM
- M SCDDDD=@SCDATES
- S SCTP0=$G(^SCTM(404.57,SCTP,0))
- S SCTPDT=-9999999 F S SCTPDT=$O(^SCTM(404.59,"AIDT",SCTP,1,SCTPDT)) Q:'SCTPDT D
- .S SCACTHIS=$$ACTHIST^SCAPMCU2(404.59,SCTP,"SCDDDD",.SCERR,"SCTPTM")
- .Q:'SCACTHIS
- .S SCND=$G(^SCTM(404.57,SCTP,0))
- .S SCU=$P(SCND,U,13)
- .Q:'$$OKUSRCL^SCAPU1(.SCUSRA,.SCU)
- .S SCR=+$P(SCND,U,3)
- .Q:'$$OKARRAY^SCAPU1(.SCROLEA,.SCR)
- .D BLD(.SCLIST,$P(SCTP0,U,2),SCTP,SCACTHIS,SCR)
- .S SCDDDD("END")=$P(SCACTHIS,U,3)-.00001
- QTVALBLD Q $G(@SCERR@(0))<1
- ;
- BLD(SCLIST,SCTM,SCTP,SCACTHIS,SCR) ; -- build list of positions
- ;
- ; SCLIST - output array
- ; SCTM - pointer to 404.51
- ; SCTP - pointer to 404.57
- ; SCACTHIS- per $$acthis^scapmcu2(file,ien)
- ; SCPTA - ien of pt team assignment
- ; SCR - role
- ;
- ; this builds the array:
- ; sclist(1->n)=SCTP^positionname^sctm^histien^effdt^inactdt^scr^rolename^scusr^usrname
- ;
- ; for each scpta zero node passed to it
- ; AND a xref sclist('SCTP',SCTM,scpt,histien,scn)=""
- N SCEFFDT,SCCNT,SCN,SCUSR
- S:'$G(SCTM) SCTM=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,2)
- Q:$D(@SCLIST@("SCTP",SCTM,SCTP,$P(SCACTHIS,U,2)))
- S SCN=$G(@SCLIST@(0),0)+1
- S @SCLIST@(0)=SCN
- S SCUSR=+$P(^SCTM(404.57,SCTP,0),U,13)
- ; 1 ^ 2 ^ 3 ^ 4
- ;
- ;;bp/djb/11-2-98/Added STATUS field to the output array (SRS 3.2.3).
- ;;old code begin
- ;S @SCLIST@(SCN)=SCTP_U_$P($G(^SCTM(404.57,SCTP,0)),U,1)_U_SCTM_U_$P(SCACTHIS,U,2,4)_U_SCR_U_$P($G(^SD(403.46,SCR,0)),U,1)_U_SCUSR_U_$P($G(^USR(8930,SCUSR,0)),U,1)_U_$P($G(SCPTTP0),U,1)
- ;;old code end
- ;;new code begin
- S @SCLIST@(SCN)=SCTP_U_$P($G(^SCTM(404.57,SCTP,0)),U,1)_U_SCTM_U_$P(SCACTHIS,U,2,4)_U_SCR_U_$P($G(^SD(403.46,SCR,0)),U,1)_U_SCUSR_U_$P($G(^USR(8930,SCUSR,0)),U,1)_U_$P($G(SCPTTP0),U,1)
- ;;new code end
- ;
- ;THE 11TH $P WAS ADDED BY JLU
- S @SCLIST@("SCTP",SCTM,SCTP,$P(SCACTHIS,U,2),SCN)=""
- Q
- OKDATA() ;setup/check variables
- N SCOK
- S SCOK=1
- D INIT^SCAPMCU1(.SCOK) ; set default dates & error array (if undefined)
- IF '$D(^SCTM(404.51,+$G(SCTM),0)) D S SCOK=0
- . S SCPARM("Team")=$G(SCTM,"Undefined")
- . D ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- Q SCOK
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC24 5039 printed Feb 19, 2025@00:04:26 Page 2
- SCAPMC24 ;ALB/REW - Team API's:TPTM ; 27 Jun 99 3:05 PM
- +1 ;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
- +2 ;;1.0
- TPTM(SCTM,SCDATES,SCUSRA,SCROLEA,SCLIST,SCERR) ; -- positions for a pract
- +1 ; input:
- +2 ; SCTM = ien of TEAM File (#404.51) [required]
- +3 ; SCDATES("BEGIN") = begin date to search (inclusive)
- +4 ; [default: TODAY]
- +5 ; ("END") = end date to search (inclusive)
- +6 ; [default: TODAY]
- +7 ; ("INCL") = 1: only use patients who were assigned to
- +8 ; team for entire date range
- +9 ; 0: anytime in date range
- +10 ; [default: 1]
- +11 ; SCUSRA -array of pointers to user file - 8930
- +12 ; if none are defined - returns all usr classes
- +13 ; if @SCPURPA@('exclude') is defined - exclude listed usr class
- +14 ; SCROLEA - array of pointers to std position file 403.46 (per scusra)
- +15 ; SCLIST -array name to store list
- +16 ; [ex. ^TMP("SCPT",$J)]
- +17 ;
- +18 ; SCERR = array NAME to store error messages.
- +19 ; [ex. ^TMP("ORXX",$J)]
- +20 ;
- +21 ; Output:
- +22 ; SCLIST() = array of positions (includes SCTP xref)
- +23 ; Format:
- +24 ; Subscript: Sequential # from 1 to n
- +25 ; Piece Description
- +26 ; 1 IEN of TEAM POSITION File (#404.57)
- +27 ; 2 Name of Position
- +28 ; 3 IEN of Team #404.51
- +29 ; 4 IEN of file #404.59 (Tm Pos History)
- +30 ; 5 current effective date
- +31 ; 6 current inactivate date (if any)
- +32 ; 7 pointer to 403.46 (role)
- +33 ; 8 Name of Standard Role
- +34 ; 9 pointer to User Class (#8930)
- +35 ; 10 Name of User Class
- +36 ; Subscript: "SCTP",SCTM,IEN =""
- +37 ;
- +38 ; SCERR() = Array of DIALOG file messages(errors) .
- +39 ; @SCERR@(0) = number of errors, undefined if none
- +40 ; Format:
- +41 ; Subscript: Sequential # from 1 to n
- +42 ; Piece Description
- +43 ; 1 IEN of DIALOG file
- +44 ; Returned: 1 if ok, 0 if error
- +45 ; Other:
- +46 ; SCACTHIS = status (-1:err|0:inact|1:act)^404.59 ien ^actdt^inacdt
- +47 ;
- +48 ;
- ST NEW SCPTTP,SCPTTP0,SCTP,SCR,SCACTHIS,SCND,SCTPTM,SCTPA
- +1 NEW SCLSEQ,SCN,SCESEQ,SCPARM,SCBEGIN,SCEND,SCINCL,SCDTS
- +2 ; -- initialize control variables
- +3 if '$$OKDATA
- GOTO PRACQ
- +4 ; -- loop through team positionS
- +5 SET (SCTP,SCTPA)=0
- +6 FOR
- SET SCTP=$ORDER(^SCTM(404.57,"C",SCTM,SCTP))
- if 'SCTP
- QUIT
- if '$$TPVALBLD(SCTP,.SCDATES,.SCPOSA,.SCUSA,.SCPURPA,.SCROLEA,.SCLIST,.SCERR)
- QUIT
- PRACQ QUIT $GET(@SCERR@(0))<1
- +1 ;
- TPVALBLD(SCTP,SCDATES,SCPOSA,SCUSA,SCPURPA,SCROLEA,SCLIST,SCERR) ;
- +1 ; this validates a team position & builds sclist array
- +2 ; returns 1 if ok, 0 if error
- +3 NEW SCTPDT,SCDDDD,SCTP0,SCU,SCR,SCTM
- +4 MERGE SCDDDD=@SCDATES
- +5 SET SCTP0=$GET(^SCTM(404.57,SCTP,0))
- +6 SET SCTPDT=-9999999
- FOR
- SET SCTPDT=$ORDER(^SCTM(404.59,"AIDT",SCTP,1,SCTPDT))
- if 'SCTPDT
- QUIT
- Begin DoDot:1
- +7 SET SCACTHIS=$$ACTHIST^SCAPMCU2(404.59,SCTP,"SCDDDD",.SCERR,"SCTPTM")
- +8 if 'SCACTHIS
- QUIT
- +9 SET SCND=$GET(^SCTM(404.57,SCTP,0))
- +10 SET SCU=$PIECE(SCND,U,13)
- +11 if '$$OKUSRCL^SCAPU1(.SCUSRA,.SCU)
- QUIT
- +12 SET SCR=+$PIECE(SCND,U,3)
- +13 if '$$OKARRAY^SCAPU1(.SCROLEA,.SCR)
- QUIT
- +14 DO BLD(.SCLIST,$PIECE(SCTP0,U,2),SCTP,SCACTHIS,SCR)
- +15 SET SCDDDD("END")=$PIECE(SCACTHIS,U,3)-.00001
- End DoDot:1
- QTVALBLD QUIT $GET(@SCERR@(0))<1
- +1 ;
- BLD(SCLIST,SCTM,SCTP,SCACTHIS,SCR) ; -- build list of positions
- +1 ;
- +2 ; SCLIST - output array
- +3 ; SCTM - pointer to 404.51
- +4 ; SCTP - pointer to 404.57
- +5 ; SCACTHIS- per $$acthis^scapmcu2(file,ien)
- +6 ; SCPTA - ien of pt team assignment
- +7 ; SCR - role
- +8 ;
- +9 ; this builds the array:
- +10 ; sclist(1->n)=SCTP^positionname^sctm^histien^effdt^inactdt^scr^rolename^scusr^usrname
- +11 ;
- +12 ; for each scpta zero node passed to it
- +13 ; AND a xref sclist('SCTP',SCTM,scpt,histien,scn)=""
- +14 NEW SCEFFDT,SCCNT,SCN,SCUSR
- +15 if '$GET(SCTM)
- SET SCTM=$PIECE($GET(^SCTM(404.57,+$GET(SCTP),0)),U,2)
- +16 if $DATA(@SCLIST@("SCTP",SCTM,SCTP,$PIECE(SCACTHIS,U,2)))
- QUIT
- +17 SET SCN=$GET(@SCLIST@(0),0)+1
- +18 SET @SCLIST@(0)=SCN
- +19 SET SCUSR=+$PIECE(^SCTM(404.57,SCTP,0),U,13)
- +20 ; 1 ^ 2 ^ 3 ^ 4
- +21 ;
- +22 ;;bp/djb/11-2-98/Added STATUS field to the output array (SRS 3.2.3).
- +23 ;;old code begin
- +24 ;S @SCLIST@(SCN)=SCTP_U_$P($G(^SCTM(404.57,SCTP,0)),U,1)_U_SCTM_U_$P(SCACTHIS,U,2,4)_U_SCR_U_$P($G(^SD(403.46,SCR,0)),U,1)_U_SCUSR_U_$P($G(^USR(8930,SCUSR,0)),U,1)_U_$P($G(SCPTTP0),U,1)
- +25 ;;old code end
- +26 ;;new code begin
- +27 SET @SCLIST@(SCN)=SCTP_U_$PIECE($GET(^SCTM(404.57,SCTP,0)),U,1)_U_SCTM_U_$PIECE(SCACTHIS,U,2,4)_U_SCR_U_$PIECE($GET(^SD(403.46,SCR,0)),U,1)_U_SCUSR_U_$PIECE($GET(^USR(8930,SCUSR,0)),U,1)_U_$PIECE($GET(SCPTTP0),U,1)
- +28 ;;new code end
- +29 ;
- +30 ;THE 11TH $P WAS ADDED BY JLU
- +31 SET @SCLIST@("SCTP",SCTM,SCTP,$PIECE(SCACTHIS,U,2),SCN)=""
- +32 QUIT
- OKDATA() ;setup/check variables
- +1 NEW SCOK
- +2 SET SCOK=1
- +3 ; set default dates & error array (if undefined)
- DO INIT^SCAPMCU1(.SCOK)
- +4 IF '$DATA(^SCTM(404.51,+$GET(SCTM),0))
- Begin DoDot:1
- +5 SET SCPARM("Team")=$GET(SCTM,"Undefined")
- +6 DO ERR^SCAPMCU1(.SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- SET SCOK=0
- +7 QUIT SCOK
- +8 ;