- SCAPMC21 ;ALB/REW - Team APIs:ACPTTP ; 5 Jul 1995
- ;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
- ;;1.0
- ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
- ; input:
- ; DFN = pointer to PATIENT file (#2)
- ; SCTP = pointer to TEAM POSTION file (#404.57)
- ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
- ; SCACT = date to activate [default=DT]
- ; SCERR = array NAME to store error messages.
- ; [ex. ^TMP("ORXX",$J)]
- ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
- ; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
- ;
- ; Output:
- ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
- ; SCERR() = Array of DIALOG file messages(errors) .
- ; Foramt:
- ; Subscript: Sequential # from 1 to n
- ; Piece Description
- ; 1 IEN of DIALOG file
- N SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA
- N SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS,SCX
- G:'$$OKDATA APTTPQ ;check/setup variables
- S SCTM=$P($G(^SCTM(404.57,SCTP,0)),U,2)
- ;S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
- S SCAPTDT("BEGIN")=SCACT
- S SCAPTDT("END")=3990101
- S SCAPTDT("INCL")=0
- IF $S('$D(SCFIELDA):0,'$D(@SCFIELDA@(.05)):0,($G(@SCFIELDA@(.05))=1):1,($G(@SCFIELDA@(.05))=2):1,1:0) IF '$$CHKPC(DFN) D G APTTPQ
- .S SCMESS=4044300.001
- ;bp/cmf 177 new begin
- S SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
- I SCX<1 S SCMESS=$P(SCX,U,2) G APTTPQ
- ;bp/cmf 177 new end
- G:'$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE") APTTPQ
- S SCPTTPA=$O(SCAPTTPO("SCTP",SCTM,SCTP,0))
- ;to edit existing entry
- IF SCPTTPA D G APTTPQ
- .S SC($J,404.43,(+SCPTTPA)_",",.03)=SCACT
- .IF $D(SCFIELDA) D
- ..S SCFLD=0
- ..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
- ...S SC($J,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
- .D FILE^DIE("","SC($J)",SCERR)
- ;needed: patient team assignment for date
- S SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
- ; if flag is set to add patient to team & no pt tm assignment exists
- ;
- IF ('SCPTTMA)&($G(SCYESTM))&($D(SCFIELDA)) D
- .S:$D(@SCFIELDA@(.05)) @SCMAINA@(.08)=$G(@SCMAINA@(.08),$S(@SCFIELDA@(.05):1,1:99))
- .S:$D(@SCFIELDA@(.06)) @SCMAINA@(.11)=$G(@SCMAINA@(.11),@SCFIELDA@(.06))
- .S:$D(@SCFIELDA@(.07)) @SCMAINA@(.12)=$G(@SCMAINA@(.12),@SCFIELDA@(.07))
- .S:$D(@SCFIELDA@(.08)) @SCMAINA@(.13)=$G(@SCMAINA@(.13),@SCFIELDA@(.08))
- .S:$D(@SCFIELDA@(.09)) @SCMAINA@(.14)=$G(@SCMAINA@(.14),@SCFIELDA@(.09))
- .S SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
- TM IF 'SCPTTMA G APTTPQ
- ELSE D
- .IF $D(SCFIELDA) D
- ..S SCFLD=0
- ..F S SCFLD=$O(@SCFIELDA@(SCFLD)) Q:'SCFLD D
- ...S SC($J,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
- .S SC($J,404.43,"+1,",.01)=SCPTTMA
- .S SC($J,404.43,"+1,",.02)=SCTP
- .S SC($J,404.43,"+1,",.03)=SCACT
- .D UPDATE^DIE("","SC($J)","SCIEN",SCERR)
- .IF $D(@SCERR) K SCIEN
- .ELSE D
- ..S SCPTTPA=+$G(SCIEN(1))
- ..S SCNEWTP=1
- ..D AFTERTP^SCMCDD1(SCPTTPA)
- APTTPQ Q +$G(SCPTTPA)_U_+$G(SCNEWTP)_U_+$G(SCPTTMA)_U_+$P($G(SCPTTMA),U,2)_U_$G(SCMESS)
- ;
- ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
- ; input: as per ACPTTP (above with the following change:)
- ; DFNA = is the literal value of a patient array (e.g. "scpt"
- ; there is at least one scpt(dfn)="" defined
- ; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
- ; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
- ; SCOLDTP = Subset of DFNA that was already assigned to Position
- ; SCBADTP = Subset of DFNA that was NOT assigned to Position
- ; output: Count of Patients (New or Old) assigned to Position
- N DFN,SCCNT,SCX,SCNOMAIL
- S SCNOMAIL=1
- S SCCNT=0
- S DFN=0 F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
- .S SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
- .; SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?
- .IF $P(SCX,U,2) D ;newly assigned
- ..S SCCNT=SCCNT+1
- ..S @SCNEWTP@(DFN)=+SCX ;scnewtp
- ..S:$P(SCX,U,4) @SCNEWTM@(DFN)=$P(SCX,U,3) ;scnewtm
- .IF $P(SCX,U,1)&('$P(SCX,U,2)) D ;old
- ..S SCCNT=SCCNT+1
- ..S @SCOLDTP@(DFN)=+SCX
- .IF 'SCX D
- ..S @SCBADTP@(DFN)=$P(SCX,U,5)
- K SCNOMAIL
- D MAILLST^SCMCTPM(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)
- Q SCCNT
- ;
- OKDATA() ;setup/check variables
- N SCOK
- S SCOK=1
- D INIT^SCAPMCU1(.SCOK)
- IF '$D(^DPT(DFN,0))!('$D(^SCTM(404.57,SCTP,0))) D S SCOK=0
- . S SCPARM("PATIENT")=DFN
- . S SCPARM("POSITION")=SCTP
- . D ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
- S:'$G(SCACT) SCACT=DT
- S:'$D(SCMAINA) SCMAINA="SC40443A"
- Q SCOK
- CHKPC(DFN) ;not stand-alone
- N SCOK,SCX
- S SCOK=1
- G:@SCFIELDA@(.05)=0 QTCKPC ;ignore if no pc role
- S SCX=$$PCRLPTTP^SCMCTPU2(DFN,SCTP,SCACT)
- IF @SCFIELDA@(.05)=1 D
- .S:'SCX SCOK=0
- IF @SCFIELDA@(.05)=2 D
- .S:'$P(SCX,U,2) SCOK=0
- QTCKPC Q SCOK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCAPMC21 5049 printed Feb 19, 2025@00:04:23 Page 2
- SCAPMC21 ;ALB/REW - Team APIs:ACPTTP ; 5 Jul 1995
- +1 ;;5.3;Scheduling;**41,148,177**;AUG 13, 1993
- +2 ;;1.0
- ACPTTP(DFN,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA) ;add/edit a patient to a position (pt TP assgn - #404.43
- +1 ; input:
- +2 ; DFN = pointer to PATIENT file (#2)
- +3 ; SCTP = pointer to TEAM POSTION file (#404.57)
- +4 ; SCFIELDA= array of extra field entries - scfielda('fld#')=value
- +5 ; SCACT = date to activate [default=DT]
- +6 ; SCERR = array NAME to store error messages.
- +7 ; [ex. ^TMP("ORXX",$J)]
- +8 ; SCYESTM = Should team assignment be made, if none active now?[1=YES]
- +9 ; SCMAINA= array of extra field entries for 404.42 (only if scyestm=1)
- +10 ;
- +11 ; Output:
- +12 ; Returned = ien of 404.43^new?^404.42 ien (new entries only)^new?^Message
- +13 ; SCERR() = Array of DIALOG file messages(errors) .
- +14 ; Foramt:
- +15 ; Subscript: Sequential # from 1 to n
- +16 ; Piece Description
- +17 ; 1 IEN of DIALOG file
- +18 NEW SCESEQ,SCPARM,SCIEN,SC,HISTPTTP,SCFLD,SCTM,SCPTTMA,SCPTTPA
- +19 NEW SCTMFLDA,SCNEWTP,SCNEWTM,SCAPTDT,SCAPTTPO,SCAPTTPE,SCMESS,SCX
- +20 ;check/setup variables
- if '$$OKDATA
- GOTO APTTPQ
- +21 SET SCTM=$PIECE($GET(^SCTM(404.57,SCTP,0)),U,2)
- +22 ;S SCPTTPA=$$HISTPTTP^SCAPMCU2(DFN,SCTP,SCACT)
- +23 SET SCAPTDT("BEGIN")=SCACT
- +24 SET SCAPTDT("END")=3990101
- +25 SET SCAPTDT("INCL")=0
- +26 IF $SELECT('$DATA(SCFIELDA):0,'$DATA(@SCFIELDA@(.05)):0,($GET(@SCFIELDA@(.05))=1):1,($GET(@SCFIELDA@(.05))=2):1,1:0)
- IF '$$CHKPC(DFN)
- Begin DoDot:1
- +27 SET SCMESS=4044300.001
- End DoDot:1
- GOTO APTTPQ
- +28 ;bp/cmf 177 new begin
- +29 SET SCX=$$OKPREC5^SCMCLK(SCTP,SCACT)
- +30 IF SCX<1
- SET SCMESS=$PIECE(SCX,U,2)
- GOTO APTTPQ
- +31 ;bp/cmf 177 new end
- +32 if '$$TPPT^SCAPMC(DFN,"SCAPTDT",,,,,0,"SCAPTTPO","SCAPTTPE")
- GOTO APTTPQ
- +33 SET SCPTTPA=$ORDER(SCAPTTPO("SCTP",SCTM,SCTP,0))
- +34 ;to edit existing entry
- +35 IF SCPTTPA
- Begin DoDot:1
- +36 SET SC($JOB,404.43,(+SCPTTPA)_",",.03)=SCACT
- +37 IF $DATA(SCFIELDA)
- Begin DoDot:2
- +38 SET SCFLD=0
- +39 FOR
- SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
- if 'SCFLD
- QUIT
- Begin DoDot:3
- +40 SET SC($JOB,404.43,(+SCPTTPA)_",",SCFLD)=@SCFIELDA@(SCFLD)
- End DoDot:3
- End DoDot:2
- +41 DO FILE^DIE("","SC($J)",SCERR)
- End DoDot:1
- GOTO APTTPQ
- +42 ;needed: patient team assignment for date
- +43 SET SCPTTMA=+$$HISTPTTM^SCAPMCU2(DFN,SCTM,SCACT)
- +44 ; if flag is set to add patient to team & no pt tm assignment exists
- +45 ;
- +46 IF ('SCPTTMA)&($GET(SCYESTM))&($DATA(SCFIELDA))
- Begin DoDot:1
- +47 if $DATA(@SCFIELDA@(.05))
- SET @SCMAINA@(.08)=$GET(@SCMAINA@(.08),$SELECT(@SCFIELDA@(.05):1,1:99))
- +48 if $DATA(@SCFIELDA@(.06))
- SET @SCMAINA@(.11)=$GET(@SCMAINA@(.11),@SCFIELDA@(.06))
- +49 if $DATA(@SCFIELDA@(.07))
- SET @SCMAINA@(.12)=$GET(@SCMAINA@(.12),@SCFIELDA@(.07))
- +50 if $DATA(@SCFIELDA@(.08))
- SET @SCMAINA@(.13)=$GET(@SCMAINA@(.13),@SCFIELDA@(.08))
- +51 if $DATA(@SCFIELDA@(.09))
- SET @SCMAINA@(.14)=$GET(@SCMAINA@(.14),@SCFIELDA@(.09))
- +52 SET SCPTTMA=+$$ACPTTM^SCAPMC(DFN,SCTM,.SCMAINA,SCACT,SCERR)
- End DoDot:1
- TM IF 'SCPTTMA
- GOTO APTTPQ
- +1 IF '$TEST
- Begin DoDot:1
- +2 IF $DATA(SCFIELDA)
- Begin DoDot:2
- +3 SET SCFLD=0
- +4 FOR
- SET SCFLD=$ORDER(@SCFIELDA@(SCFLD))
- if 'SCFLD
- QUIT
- Begin DoDot:3
- +5 SET SC($JOB,404.43,"+1,",SCFLD)=@SCFIELDA@(SCFLD)
- End DoDot:3
- End DoDot:2
- +6 SET SC($JOB,404.43,"+1,",.01)=SCPTTMA
- +7 SET SC($JOB,404.43,"+1,",.02)=SCTP
- +8 SET SC($JOB,404.43,"+1,",.03)=SCACT
- +9 DO UPDATE^DIE("","SC($J)","SCIEN",SCERR)
- +10 IF $DATA(@SCERR)
- KILL SCIEN
- +11 IF '$TEST
- Begin DoDot:2
- +12 SET SCPTTPA=+$GET(SCIEN(1))
- +13 SET SCNEWTP=1
- +14 DO AFTERTP^SCMCDD1(SCPTTPA)
- End DoDot:2
- End DoDot:1
- APTTPQ QUIT +$GET(SCPTTPA)_U_+$GET(SCNEWTP)_U_+$GET(SCPTTMA)_U_+$PIECE($GET(SCPTTMA),U,2)_U_$GET(SCMESS)
- +1 ;
- ACPTATP(DFNA,SCTP,SCFIELDA,SCACT,SCERR,SCYESTM,SCMAINA,SCNEWTP,SCNEWTM,SCOLDTP,SCBADTP) ;list of patients to a position (pt TP assgn - #404.43 and possibly #404.42
- +1 ; input: as per ACPTTP (above with the following change:)
- +2 ; DFNA = is the literal value of a patient array (e.g. "scpt"
- +3 ; there is at least one scpt(dfn)="" defined
- +4 ; SCNEWTP = Subset of DFNA that was NEWLY assigned to a Position
- +5 ; SCNEWTM = Subset of DFNA that was NEWLY assigned to a Team
- +6 ; SCOLDTP = Subset of DFNA that was already assigned to Position
- +7 ; SCBADTP = Subset of DFNA that was NOT assigned to Position
- +8 ; output: Count of Patients (New or Old) assigned to Position
- +9 NEW DFN,SCCNT,SCX,SCNOMAIL
- +10 SET SCNOMAIL=1
- +11 SET SCCNT=0
- +12 SET DFN=0
- FOR
- SET DFN=$ORDER(@DFNA@(DFN))
- if 'DFN
- QUIT
- Begin DoDot:1
- +13 SET SCX=$$ACPTTP(.DFN,.SCTP,.SCFIELDA,.SCACT,.SCERR,.SCYESTM)
- +14 ; SCX = ien of 404.43^new?^404.42 ien (new entries only)^new?
- +15 ;newly assigned
- IF $PIECE(SCX,U,2)
- Begin DoDot:2
- +16 SET SCCNT=SCCNT+1
- +17 ;scnewtp
- SET @SCNEWTP@(DFN)=+SCX
- +18 ;scnewtm
- if $PIECE(SCX,U,4)
- SET @SCNEWTM@(DFN)=$PIECE(SCX,U,3)
- End DoDot:2
- +19 ;old
- IF $PIECE(SCX,U,1)&('$PIECE(SCX,U,2))
- Begin DoDot:2
- +20 SET SCCNT=SCCNT+1
- +21 SET @SCOLDTP@(DFN)=+SCX
- End DoDot:2
- +22 IF 'SCX
- Begin DoDot:2
- +23 SET @SCBADTP@(DFN)=$PIECE(SCX,U,5)
- End DoDot:2
- End DoDot:1
- +24 KILL SCNOMAIL
- +25 DO MAILLST^SCMCTPM(SCTP,.SCADDFLD,DT,.SCNEWTP,.SCOLDTP,.SCBADTP)
- +26 QUIT SCCNT
- +27 ;
- OKDATA() ;setup/check variables
- +1 NEW SCOK
- +2 SET SCOK=1
- +3 DO INIT^SCAPMCU1(.SCOK)
- +4 IF '$DATA(^DPT(DFN,0))!('$DATA(^SCTM(404.57,SCTP,0)))
- Begin DoDot:1
- +5 SET SCPARM("PATIENT")=DFN
- +6 SET SCPARM("POSITION")=SCTP
- +7 DO ERR^SCAPMCU1(SCESEQ,4045101,.SCPARM,"",.SCERR)
- End DoDot:1
- SET SCOK=0
- +8 if '$GET(SCACT)
- SET SCACT=DT
- +9 if '$DATA(SCMAINA)
- SET SCMAINA="SC40443A"
- +10 QUIT SCOK
- CHKPC(DFN) ;not stand-alone
- +1 NEW SCOK,SCX
- +2 SET SCOK=1
- +3 ;ignore if no pc role
- if @SCFIELDA@(.05)=0
- GOTO QTCKPC
- +4 SET SCX=$$PCRLPTTP^SCMCTPU2(DFN,SCTP,SCACT)
- +5 IF @SCFIELDA@(.05)=1
- Begin DoDot:1
- +6 if 'SCX
- SET SCOK=0
- End DoDot:1
- +7 IF @SCFIELDA@(.05)=2
- Begin DoDot:1
- +8 if '$PIECE(SCX,U,2)
- SET SCOK=0
- End DoDot:1
- QTCKPC QUIT SCOK