SCMCDD1 ;ALB/REW - DD Calls used by PCMM ; 6 November 1995
;;5.3;Scheduling;**41,89,107,1015**;AUG 13, 1993;Build 21
;1
WRITETP(SCTP) ;used by write node of 404.57
N SCCL
S SCCL=$P($G(^SCTM(404.57,+$G(SCTP),0)),U,9)
Q $P($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_" "_$P($G(^SC(+$G(SCCL),0)),U,1)
;
SETPTTM(SCPTTMA) ;delete
Q
;
KILLPTTM(SCPTTMA) ;delete
Q
;
AFTERTM(SCPTTM) ;called after update of 404.42
N SCPTTMB4,SCPCTMB4,SCTMB4,SCTMNDB4,SCPTTMAF,SCPCTMAF,SCTMAF,X,SCFLD,SCX,SCTMNDAF,SCTMNMB4,Y
Q:'$G(SCPTTM)
S SCPTTMAF=$G(^SCPT(404.42,SCPTTM,0))
S SCPCTMAF=$S(($P(SCPTTMAF,U,8)=1):1,1:0)
S SCTMAF=$P(SCPTTMAF,U,3)
S:SCTMAF SCTMNDAF=$G(^SCTM(404.51,SCTMAF,0))
F X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNMB4" S @X=$G(^TMP($J,"SCTMCHG",SCPTTM,X))
F SCFLD=1:1:14 S SCX=$P(SCPTTMAF,U,SCFLD) S:SCX'="" ^TMP($J,"SCTMCHG",SCPTTM,"AF",(SCFLD*.01))=SCX
S X=+$O(^ORD(101,"B","SCMC PATIENT TEAM CHANGES",0))_";ORD(101,"
D:SCPTTMAF'=SCPTTMB4 EN^XQOR
K ^TMP($J,"SCTMCHG",SCPTTM)
Q
;
BEFORETM(SCPTTM) ;called before update of 404.42
N SCPTTMB4,SCPCTMB4,SCTMB4,SCTMNDB4,X,SCFLD,SCX,SCY,DR,DIC,DA,DIQ
Q:'$G(SCPTTM)
S SCPTTMB4=$G(^SCPT(404.42,SCPTTM,0))
S SCPCTMB4=$S(($P(SCPTTMB4,U,8)=1):1,1:0)
S SCTMB4=$P(SCPTTMB4,U,3)
S:SCTMB4 SCTMNDB4=$G(^SCTM(404.51,SCTMB4,0))
F X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNDB4" S ^TMP($J,"SCTMCHG",SCPTTM,X)=$G(@X)
F SCY=1:1:14 S SCX=$P(SCPTTMB4,U,SCY) IF SCX'="" D
.S SCFLD=SCY*.01
.S ^TMP($J,"SCTMCHG",SCPTTM,"B4",SCFLD)=SCX
Q
;
SETPC(SC1,SC2,SC3,SC4,DA) ;APCPOS xref for 404.43
;DFN = Pointer to Patient File
;SC1 = pointer to 404.42
;SC2 = ROLE (1=pc practitioner,2=pc attending)
;SC3 = Activation Date
;SC4 = Team Position
N DFN
S DFN=$P($G(^SCPT(404.42,SC1,0)),U,1)
S:DFN&SC1&SC2&SC3&SC4&DA ^SCPT(404.43,"APCPOS",DFN,SC2,SC3,SC4,DA)=""
Q
KILLPC(SC1,SC2,SC3,SC4,DA) ;APCPOS xref for 404.43
;DFN = Pointer to Patient File
;SC1 = pointer to 404.42
;SC2 = ROLE (1=pc practitioner,2=pc attending)
;SC3 = Activation Date
;SC4 = Team Position
N DFN
S DFN=$P($G(^SCPT(404.42,SC1,0)),U,1)
K:DFN&SC1&SC2&SC3&SC4&DA ^SCPT(404.43,"APCPOS",DFN,SC2,SC3,SC4,DA)
Q
;
MAKEMANY(DFNA,SCOLDASS,SCBADASS,SCNEWASS) ;Not supported for use by PCMM Only - sets PC field to YES
; DFNA - DFN ARRAY
; SCOLDASS - Subset of DFNA that were previously assigned
; SCBADASS - Subset of DFNA that could not be assigned
; SCNEWASS - Subset of DFNA that were newly assigned
; Returned: total^new^old^bad
; Note: No input error checking!!
N DFN,SCX,SCOUTFLD,SCBADOUT,SCOLDCNT,SCBADCNT,SCNEWCNT
S (SCBADCNT,SCOLDCNT,SCNEWCNT)=0
S DFN=0
F S DFN=$O(@DFNA@(DFN)) Q:'DFN D
.S SCOUTFLD(.04)=1
.S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
.;SCX=OK?^p404.41^new?
.IF 'SCX D
..S SCBADCNT=SCBADCNT+1
..S @SCBADASS@(DFN)=""
.ELSE D
..IF $P(SCX,U,3) D
...S SCNEWCNT=SCNEWCNT+1
...S @SCNEWASS@(DFN)=""
..ELSE D
...S SCOLDCNT=SCOLDCNT+1
...S @SCOLDASS@(DFN)=""
Q (SCOLDCNT+SCNEWCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
;
MAKEOUT(DA) ;used by 404.42 to create an outpatient profile entry (if there wasn't one) and set the PRIMARY CARE?(.04) field to YES
; Returned (for de-bugging): ok?^ien of404.41^new?
N SCNODE,SCX,DFN,SCOUTFLD
S SCNODE=$G(^SCPT(404.42,+$G(DA),0))
S DFN=$P(SCNODE,U,1)
IF $P(SCNODE,U,8)=1 D ;if assignment was to primary care
.S SCOUTFLD(.04)=1
.S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
Q $G(SCX)
;
AFTERTP(SCPTTP) ;called after update of 404.43
N SCPTTPB4,SCPCTPB4,SCTPB4,SCTPNDB4,SCPTTPAF,SCPCTPAF,SCTPAF,X,SCFLD,SCX,SCTMB4,SCTMNDB4,SCTMNDAF,SCTMAF,SCPTNM,SCTPNDAF,SCTPNMB4,Y
Q:'$G(SCPTTP)
S SCPTTPAF=$G(^SCPT(404.43,SCPTTP,0))
S SCPCTPAF=+$P(SCPTTPAF,U,5)
S SCTPAF=$P(SCPTTPAF,U,2)
S:SCTPAF SCTPNDAF=$G(^SCTM(404.57,SCTPAF,0))
S:SCTPAF SCTMAF=$P(SCTPNDAF,U,2)
S:SCTMAF SCTMNDAF=$G(^SCTM(404.51,SCTMAF,0))
F X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNMB4","SCTMB4","SCTMNDB4" S @X=$G(^TMP($J,"SCTPCHG",SCPTTP,X))
F SCFLD=1:1:9 S SCX=$P(SCPTTPAF,U,SCFLD) S:SCX'="" ^TMP($J,"SCTPCHG",SCPTTP,"AF",(SCFLD*.01))=SCX
S X=+$O(^ORD(101,"B","SCMC PATIENT TEAM POSITION CHANGES",0))_";ORD(101,"
D:SCPTTPAF'=SCPTTPB4 EN^XQOR
K ^TMP($J,"SCTPCHG",SCPTTP)
Q
;
BEFORETP(SCPTTP) ;called before update of 404.43
N SCPTTPB4,SCPCTPB4,SCTPB4,SCTPNDB4,X,SCFLD,SCX,SCY,DR,DIC,DA,DIQ,SCTMB4,SCTMNDAF,SCTMNDB4,SCTMNMB4
Q:'$G(SCPTTP)
S SCPTTPB4=$G(^SCPT(404.43,SCPTTP,0))
Q:'SCPTTPB4
S SCPCTPB4=+$P(SCPTTPB4,U,5)
S SCTPB4=$P(SCPTTPB4,U,2)
S:SCTPB4 SCTPNDB4=$G(^SCTM(404.57,SCTPB4,0))
S:SCTPB4 SCTMB4=$P(SCTPNDB4,U,2)
S:SCTMB4 SCTMNDB4=$G(^SCTM(404.51,SCTMB4,0))
F X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNDB4","SCTMNDB4","SCTMB4" S ^TMP($J,"SCTPCHG",SCPTTP,X)=$G(@X)
F SCY=1:1:9 S SCX=$P(SCPTTPB4,U,SCY) IF SCX'="" D
.S SCFLD=SCY*.01
.S ^TMP($J,"SCTPCHG",SCPTTP,"B4",SCFLD)=SCX
Q
SCMCDD1 ;ALB/REW - DD Calls used by PCMM ; 6 November 1995
+1 ;;5.3;Scheduling;**41,89,107,1015**;AUG 13, 1993;Build 21
+2 ;1
WRITETP(SCTP) ;used by write node of 404.57
+1 NEW SCCL
+2 SET SCCL=$PIECE($GET(^SCTM(404.57,+$GET(SCTP),0)),U,9)
+3 QUIT $PIECE($$GETPRTP^SCAPMCU2(SCTP,DT),U,2)_" "_$PIECE($GET(^SC(+$GET(SCCL),0)),U,1)
+4 ;
SETPTTM(SCPTTMA) ;delete
+1 QUIT
+2 ;
KILLPTTM(SCPTTMA) ;delete
+1 QUIT
+2 ;
AFTERTM(SCPTTM) ;called after update of 404.42
+1 NEW SCPTTMB4,SCPCTMB4,SCTMB4,SCTMNDB4,SCPTTMAF,SCPCTMAF,SCTMAF,X,SCFLD,SCX,SCTMNDAF,SCTMNMB4,Y
+2 IF '$GET(SCPTTM)
QUIT
+3 SET SCPTTMAF=$GET(^SCPT(404.42,SCPTTM,0))
+4 SET SCPCTMAF=$SELECT(($PIECE(SCPTTMAF,U,8)=1):1,1:0)
+5 SET SCTMAF=$PIECE(SCPTTMAF,U,3)
+6 IF SCTMAF
SET SCTMNDAF=$GET(^SCTM(404.51,SCTMAF,0))
+7 FOR X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNMB4"
SET @X=$GET(^TMP($JOB,"SCTMCHG",SCPTTM,X))
+8 FOR SCFLD=1:1:14
SET SCX=$PIECE(SCPTTMAF,U,SCFLD)
IF SCX'=""
SET ^TMP($JOB,"SCTMCHG",SCPTTM,"AF",(SCFLD*.01))=SCX
+9 SET X=+$ORDER(^ORD(101,"B","SCMC PATIENT TEAM CHANGES",0))_";ORD(101,"
+10 IF SCPTTMAF'=SCPTTMB4
DO EN^XQOR
+11 KILL ^TMP($JOB,"SCTMCHG",SCPTTM)
+12 QUIT
+13 ;
BEFORETM(SCPTTM) ;called before update of 404.42
+1 NEW SCPTTMB4,SCPCTMB4,SCTMB4,SCTMNDB4,X,SCFLD,SCX,SCY,DR,DIC,DA,DIQ
+2 IF '$GET(SCPTTM)
QUIT
+3 SET SCPTTMB4=$GET(^SCPT(404.42,SCPTTM,0))
+4 SET SCPCTMB4=$SELECT(($PIECE(SCPTTMB4,U,8)=1):1,1:0)
+5 SET SCTMB4=$PIECE(SCPTTMB4,U,3)
+6 IF SCTMB4
SET SCTMNDB4=$GET(^SCTM(404.51,SCTMB4,0))
+7 FOR X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNDB4"
SET ^TMP($JOB,"SCTMCHG",SCPTTM,X)=$GET(@X)
+8 FOR SCY=1:1:14
SET SCX=$PIECE(SCPTTMB4,U,SCY)
IF SCX'=""
Begin DoDot:1
+9 SET SCFLD=SCY*.01
+10 SET ^TMP($JOB,"SCTMCHG",SCPTTM,"B4",SCFLD)=SCX
End DoDot:1
+11 QUIT
+12 ;
SETPC(SC1,SC2,SC3,SC4,DA) ;APCPOS xref for 404.43
+1 ;DFN = Pointer to Patient File
+2 ;SC1 = pointer to 404.42
+3 ;SC2 = ROLE (1=pc practitioner,2=pc attending)
+4 ;SC3 = Activation Date
+5 ;SC4 = Team Position
+6 NEW DFN
+7 SET DFN=$PIECE($GET(^SCPT(404.42,SC1,0)),U,1)
+8 IF DFN&SC1&SC2&SC3&SC4&DA
SET ^SCPT(404.43,"APCPOS",DFN,SC2,SC3,SC4,DA)=""
+9 QUIT
KILLPC(SC1,SC2,SC3,SC4,DA) ;APCPOS xref for 404.43
+1 ;DFN = Pointer to Patient File
+2 ;SC1 = pointer to 404.42
+3 ;SC2 = ROLE (1=pc practitioner,2=pc attending)
+4 ;SC3 = Activation Date
+5 ;SC4 = Team Position
+6 NEW DFN
+7 SET DFN=$PIECE($GET(^SCPT(404.42,SC1,0)),U,1)
+8 IF DFN&SC1&SC2&SC3&SC4&DA
KILL ^SCPT(404.43,"APCPOS",DFN,SC2,SC3,SC4,DA)
+9 QUIT
+10 ;
MAKEMANY(DFNA,SCOLDASS,SCBADASS,SCNEWASS) ;Not supported for use by PCMM Only - sets PC field to YES
+1 ; DFNA - DFN ARRAY
+2 ; SCOLDASS - Subset of DFNA that were previously assigned
+3 ; SCBADASS - Subset of DFNA that could not be assigned
+4 ; SCNEWASS - Subset of DFNA that were newly assigned
+5 ; Returned: total^new^old^bad
+6 ; Note: No input error checking!!
+7 NEW DFN,SCX,SCOUTFLD,SCBADOUT,SCOLDCNT,SCBADCNT,SCNEWCNT
+8 SET (SCBADCNT,SCOLDCNT,SCNEWCNT)=0
+9 SET DFN=0
+10 FOR
SET DFN=$ORDER(@DFNA@(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+11 SET SCOUTFLD(.04)=1
+12 SET SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
+13 ;SCX=OK?^p404.41^new?
+14 IF 'SCX
Begin DoDot:2
+15 SET SCBADCNT=SCBADCNT+1
+16 SET @SCBADASS@(DFN)=""
End DoDot:2
+17 IF '$TEST
Begin DoDot:2
+18 IF $PIECE(SCX,U,3)
Begin DoDot:3
+19 SET SCNEWCNT=SCNEWCNT+1
+20 SET @SCNEWASS@(DFN)=""
End DoDot:3
+21 IF '$TEST
Begin DoDot:3
+22 SET SCOLDCNT=SCOLDCNT+1
+23 SET @SCOLDASS@(DFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT (SCOLDCNT+SCNEWCNT)_U_SCNEWCNT_U_SCOLDCNT_U_SCBADCNT
+25 ;
MAKEOUT(DA) ;used by 404.42 to create an outpatient profile entry (if there wasn't one) and set the PRIMARY CARE?(.04) field to YES
+1 ; Returned (for de-bugging): ok?^ien of404.41^new?
+2 NEW SCNODE,SCX,DFN,SCOUTFLD
+3 SET SCNODE=$GET(^SCPT(404.42,+$GET(DA),0))
+4 SET DFN=$PIECE(SCNODE,U,1)
+5 ;if assignment was to primary care
IF $PIECE(SCNODE,U,8)=1
Begin DoDot:1
+6 SET SCOUTFLD(.04)=1
+7 SET SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
End DoDot:1
+8 QUIT $GET(SCX)
+9 ;
AFTERTP(SCPTTP) ;called after update of 404.43
+1 NEW SCPTTPB4,SCPCTPB4,SCTPB4,SCTPNDB4,SCPTTPAF,SCPCTPAF,SCTPAF,X,SCFLD,SCX,SCTMB4,SCTMNDB4,SCTMNDAF,SCTMAF,SCPTNM,SCTPNDAF,SCTPNMB4,Y
+2 IF '$GET(SCPTTP)
QUIT
+3 SET SCPTTPAF=$GET(^SCPT(404.43,SCPTTP,0))
+4 SET SCPCTPAF=+$PIECE(SCPTTPAF,U,5)
+5 SET SCTPAF=$PIECE(SCPTTPAF,U,2)
+6 IF SCTPAF
SET SCTPNDAF=$GET(^SCTM(404.57,SCTPAF,0))
+7 IF SCTPAF
SET SCTMAF=$PIECE(SCTPNDAF,U,2)
+8 IF SCTMAF
SET SCTMNDAF=$GET(^SCTM(404.51,SCTMAF,0))
+9 FOR X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNMB4","SCTMB4","SCTMNDB4"
SET @X=$GET(^TMP($JOB,"SCTPCHG",SCPTTP,X))
+10 FOR SCFLD=1:1:9
SET SCX=$PIECE(SCPTTPAF,U,SCFLD)
IF SCX'=""
SET ^TMP($JOB,"SCTPCHG",SCPTTP,"AF",(SCFLD*.01))=SCX
+11 SET X=+$ORDER(^ORD(101,"B","SCMC PATIENT TEAM POSITION CHANGES",0))_";ORD(101,"
+12 IF SCPTTPAF'=SCPTTPB4
DO EN^XQOR
+13 KILL ^TMP($JOB,"SCTPCHG",SCPTTP)
+14 QUIT
+15 ;
BEFORETP(SCPTTP) ;called before update of 404.43
+1 NEW SCPTTPB4,SCPCTPB4,SCTPB4,SCTPNDB4,X,SCFLD,SCX,SCY,DR,DIC,DA,DIQ,SCTMB4,SCTMNDAF,SCTMNDB4,SCTMNMB4
+2 IF '$GET(SCPTTP)
QUIT
+3 SET SCPTTPB4=$GET(^SCPT(404.43,SCPTTP,0))
+4 IF 'SCPTTPB4
QUIT
+5 SET SCPCTPB4=+$PIECE(SCPTTPB4,U,5)
+6 SET SCTPB4=$PIECE(SCPTTPB4,U,2)
+7 IF SCTPB4
SET SCTPNDB4=$GET(^SCTM(404.57,SCTPB4,0))
+8 IF SCTPB4
SET SCTMB4=$PIECE(SCTPNDB4,U,2)
+9 IF SCTMB4
SET SCTMNDB4=$GET(^SCTM(404.51,SCTMB4,0))
+10 FOR X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNDB4","SCTMNDB4","SCTMB4"
SET ^TMP($JOB,"SCTPCHG",SCPTTP,X)=$GET(@X)
+11 FOR SCY=1:1:9
SET SCX=$PIECE(SCPTTPB4,U,SCY)
IF SCX'=""
Begin DoDot:1
+12 SET SCFLD=SCY*.01
+13 SET ^TMP($JOB,"SCTPCHG",SCPTTP,"B4",SCFLD)=SCX
End DoDot:1
+14 QUIT
