- 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 Feb 19, 2025@00:06:33 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