SCMCDD1 ;ALB/REW/ART - DD Calls used by PCMM ; 08/25/2014
;;5.3;Scheduling;**41,89,107,603,811**;AUG 13, 1993;Build 3
;
; Reference to ^ORD(101,"B" supported by DBIA 3617
;
;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))
Q:'SCPTTMAF ;603
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)
K ^TMP($J,"SCTMCHG",SCPTTM)
S SCPTTMB4=$G(^SCPT(404.42,SCPTTM,0))
Q:'SCPTTMB4 ;603
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
; Input: DA - 404.42 IEN
; Returned (for de-bugging): ok?^ien of404.41^new?
; 603 - create record for all assignment types
N SCNODE,SCX,DFN,SCOUTFLD,SCASSIGN
S SCNODE=$G(^SCPT(404.42,+$G(DA),0))
S DFN=$P(SCNODE,U,1)
S SCASSIGN=$P(SCNODE,U,8)
S SCOUTFLD(.04)=$S(SCASSIGN=1:"Y",SCASSIGN=98:"Y",SCASSIGN=99:"N",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,SCLP
Q:'$G(SCPTTP)
S SCPTTPAF=$G(^SCPT(404.43,SCPTTP,0))
Q:'SCPTTPAF ;603
I SCPTTPAF'["^" D ; *811 - check if SCPTTPAF contains full zero node
.F SCLP=1:1:2 I SCPTTPAF'["^" H 1 S SCPTTPAF=$G(^SCPT(404.43,SCPTTP,0)) ; *811 - hang for up to 2 seconds to let full 404.43 record populate
Q:SCPTTPAF'["^" ; *811 - quit if still no data after hang
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)
K ^TMP($J,"SCTPCHG",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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCDD1 5485 printed Apr 09, 2024@21:58:42 Page 2
SCMCDD1 ;ALB/REW/ART - DD Calls used by PCMM ; 08/25/2014
+1 ;;5.3;Scheduling;**41,89,107,603,811**;AUG 13, 1993;Build 3
+2 ;
+3 ; Reference to ^ORD(101,"B" supported by DBIA 3617
+4 ;
+5 ;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 ;603
if 'SCPTTMAF
QUIT
+5 SET SCPCTMAF=$SELECT(($PIECE(SCPTTMAF,U,8)=1):1,1:0)
+6 SET SCTMAF=$PIECE(SCPTTMAF,U,3)
+7 if SCTMAF
SET SCTMNDAF=$GET(^SCTM(404.51,SCTMAF,0))
+8 FOR X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNMB4"
SET @X=$GET(^TMP($JOB,"SCTMCHG",SCPTTM,X))
+9 FOR SCFLD=1:1:14
SET SCX=$PIECE(SCPTTMAF,U,SCFLD)
if SCX'=""
SET ^TMP($JOB,"SCTMCHG",SCPTTM,"AF",(SCFLD*.01))=SCX
+10 SET X=+$ORDER(^ORD(101,"B","SCMC PATIENT TEAM CHANGES",0))_";ORD(101,"
+11 if SCPTTMAF'=SCPTTMB4
DO EN^XQOR
+12 KILL ^TMP($JOB,"SCTMCHG",SCPTTM)
+13 QUIT
+14 ;
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 KILL ^TMP($JOB,"SCTMCHG",SCPTTM)
+4 SET SCPTTMB4=$GET(^SCPT(404.42,SCPTTM,0))
+5 ;603
if 'SCPTTMB4
QUIT
+6 SET SCPCTMB4=$SELECT(($PIECE(SCPTTMB4,U,8)=1):1,1:0)
+7 SET SCTMB4=$PIECE(SCPTTMB4,U,3)
+8 if SCTMB4
SET SCTMNDB4=$GET(^SCTM(404.51,SCTMB4,0))
+9 FOR X="SCPTTMB4","SCPCTMB4","SCTMB4","SCTMNDB4"
SET ^TMP($JOB,"SCTMCHG",SCPTTM,X)=$GET(@X)
+10 FOR SCY=1:1:14
SET SCX=$PIECE(SCPTTMB4,U,SCY)
IF SCX'=""
Begin DoDot:1
+11 SET SCFLD=SCY*.01
+12 SET ^TMP($JOB,"SCTMCHG",SCPTTM,"B4",SCFLD)=SCX
End DoDot:1
+13 QUIT
+14 ;
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 ; Input: DA - 404.42 IEN
+2 ; Returned (for de-bugging): ok?^ien of404.41^new?
+3 ; 603 - create record for all assignment types
+4 NEW SCNODE,SCX,DFN,SCOUTFLD,SCASSIGN
+5 SET SCNODE=$GET(^SCPT(404.42,+$GET(DA),0))
+6 SET DFN=$PIECE(SCNODE,U,1)
+7 SET SCASSIGN=$PIECE(SCNODE,U,8)
+8 SET SCOUTFLD(.04)=$SELECT(SCASSIGN=1:"Y",SCASSIGN=98:"Y",SCASSIGN=99:"N",1:"")
+9 SET SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
+10 QUIT $GET(SCX)
+11 ;
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,SCLP
+2 if '$GET(SCPTTP)
QUIT
+3 SET SCPTTPAF=$GET(^SCPT(404.43,SCPTTP,0))
+4 ;603
if 'SCPTTPAF
QUIT
+5 ; *811 - check if SCPTTPAF contains full zero node
IF SCPTTPAF'["^"
Begin DoDot:1
+6 ; *811 - hang for up to 2 seconds to let full 404.43 record populate
FOR SCLP=1:1:2
IF SCPTTPAF'["^"
HANG 1
SET SCPTTPAF=$GET(^SCPT(404.43,SCPTTP,0))
End DoDot:1
+7 ; *811 - quit if still no data after hang
if SCPTTPAF'["^"
QUIT
+8 SET SCPCTPAF=+$PIECE(SCPTTPAF,U,5)
+9 SET SCTPAF=$PIECE(SCPTTPAF,U,2)
+10 if SCTPAF
SET SCTPNDAF=$GET(^SCTM(404.57,SCTPAF,0))
+11 if SCTPAF
SET SCTMAF=$PIECE(SCTPNDAF,U,2)
+12 if SCTMAF
SET SCTMNDAF=$GET(^SCTM(404.51,SCTMAF,0))
+13 FOR X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNMB4","SCTMB4","SCTMNDB4"
SET @X=$GET(^TMP($JOB,"SCTPCHG",SCPTTP,X))
+14 FOR SCFLD=1:1:9
SET SCX=$PIECE(SCPTTPAF,U,SCFLD)
if SCX'=""
SET ^TMP($JOB,"SCTPCHG",SCPTTP,"AF",(SCFLD*.01))=SCX
+15 SET X=+$ORDER(^ORD(101,"B","SCMC PATIENT TEAM POSITION CHANGES",0))_";ORD(101,"
+16 if SCPTTPAF'=SCPTTPB4
DO EN^XQOR
+17 KILL ^TMP($JOB,"SCTPCHG",SCPTTP)
+18 QUIT
+19 ;
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 KILL ^TMP($JOB,"SCTPCHG",SCPTTP)
+4 SET SCPTTPB4=$GET(^SCPT(404.43,SCPTTP,0))
+5 if 'SCPTTPB4
QUIT
+6 SET SCPCTPB4=+$PIECE(SCPTTPB4,U,5)
+7 SET SCTPB4=$PIECE(SCPTTPB4,U,2)
+8 if SCTPB4
SET SCTPNDB4=$GET(^SCTM(404.57,SCTPB4,0))
+9 if SCTPB4
SET SCTMB4=$PIECE(SCTPNDB4,U,2)
+10 if SCTMB4
SET SCTMNDB4=$GET(^SCTM(404.51,SCTMB4,0))
+11 FOR X="SCPTTPB4","SCPCTPB4","SCTPB4","SCTPNDB4","SCTMNDB4","SCTMB4"
SET ^TMP($JOB,"SCTPCHG",SCPTTP,X)=$GET(@X)
+12 FOR SCY=1:1:9
SET SCX=$PIECE(SCPTTPB4,U,SCY)
IF SCX'=""
Begin DoDot:1
+13 SET SCFLD=SCY*.01
+14 SET ^TMP($JOB,"SCTPCHG",SCPTTP,"B4",SCFLD)=SCX
End DoDot:1
+15 QUIT
