- SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996
- ;;5.3;Scheduling;**41,130**;AUG 13, 1993
- ;
- PCMMDIS ; - called by 'SC ASSIGN PC TEAM ON DISCHARGE' which is
- ; called by the patient movement event driver
- Q:$D(ZTQUEUED) ;interactive - quit if queued
- ;check if patient has a current PC team if no prompt to enroll
- Q:$P($G(DGPMA),U,2)'=3 ;must be a discharge
- Q:'$G(DFN) ;should exist
- Q:'$P($G(^SD(404.91,1,"PCMM")),U,2) ; check turn off flag
- N DIR,DIRUT,DIROUT,SCTMERR,DIC,X,Y,SCOK,SCX,SCOUTFLD,SCBADOUT
- D:'$G(DGQUIET) EN^DDIOL("Checking Primary Care Status...")
- ;display PC info, check if patient has a current PC team
- D PCMM^SCRPU4(DFN,DT)
- G:$$NMPCTM^SCAPMCU2(DFN,DT,1) END
- ;if not, check if patient has a PC team in the future
- S SCOK=$$YSPTTMPC^SCMCTMU2(DFN,DT)
- IF 'SCOK D G END
- .D:'$G(DGQUIET) EN^DDIOL($P(SCOK,U,2))
- ;if not either, ask if they want to assign a patient to a PC team
- S DIR(0)="Y"
- S DIR("A")="Do you wish to assign patient to Primary Care"
- S DIR("B")="NO"
- D ^DIR
- G:'Y END
- S DIR(0)="Y"
- S DIR("A")="Do you wish to assign patient to a Primary Care Team"
- S DIR("B")="NO"
- D ^DIR
- IF 'Y D G END
- .S SCOUTFLD(.04)=1
- .S SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
- .D:SCX&'($G(DGQUIET)) EN^DDIOL("Patient Assigned to Primary Care, but no Team Assigned...")
- S DIC="^SCTM(404.51,"
- S DIC(0)="AEMQZ"
- S DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
- ; - select from active teams that can be PC Teams
- D ^DIC
- G:Y<1 END
- S SCTM=+Y
- ;setup fields
- S SCTMFLDS(.02)=DT
- S SCTMFLDS(.08)=1 ;primary care assignment
- S SCTMFLDS(.11)=$G(DUZ,.5)
- D NOW^%DTC S SCTMFLDS(.12)=%
- IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",DT,"SCTPTME") D
- .D:'$G(DGQUIET) EN^DDIOL("...PC Team Assignment Made")
- END ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCPM1 1830 printed Jan 18, 2025@03:42:17 Page 2
- SCMCPM1 ;ALB/REW - Pt PC Team Assignment on Inpt Discharge ; 1 Apr 1996
- +1 ;;5.3;Scheduling;**41,130**;AUG 13, 1993
- +2 ;
- PCMMDIS ; - called by 'SC ASSIGN PC TEAM ON DISCHARGE' which is
- +1 ; called by the patient movement event driver
- +2 ;interactive - quit if queued
- if $DATA(ZTQUEUED)
- QUIT
- +3 ;check if patient has a current PC team if no prompt to enroll
- +4 ;must be a discharge
- if $PIECE($GET(DGPMA),U,2)'=3
- QUIT
- +5 ;should exist
- if '$GET(DFN)
- QUIT
- +6 ; check turn off flag
- if '$PIECE($GET(^SD(404.91,1,"PCMM")),U,2)
- QUIT
- +7 NEW DIR,DIRUT,DIROUT,SCTMERR,DIC,X,Y,SCOK,SCX,SCOUTFLD,SCBADOUT
- +8 if '$GET(DGQUIET)
- DO EN^DDIOL("Checking Primary Care Status...")
- +9 ;display PC info, check if patient has a current PC team
- +10 DO PCMM^SCRPU4(DFN,DT)
- +11 if $$NMPCTM^SCAPMCU2(DFN,DT,1)
- GOTO END
- +12 ;if not, check if patient has a PC team in the future
- +13 SET SCOK=$$YSPTTMPC^SCMCTMU2(DFN,DT)
- +14 IF 'SCOK
- Begin DoDot:1
- +15 if '$GET(DGQUIET)
- DO EN^DDIOL($PIECE(SCOK,U,2))
- End DoDot:1
- GOTO END
- +16 ;if not either, ask if they want to assign a patient to a PC team
- +17 SET DIR(0)="Y"
- +18 SET DIR("A")="Do you wish to assign patient to Primary Care"
- +19 SET DIR("B")="NO"
- +20 DO ^DIR
- +21 if 'Y
- GOTO END
- +22 SET DIR(0)="Y"
- +23 SET DIR("A")="Do you wish to assign patient to a Primary Care Team"
- +24 SET DIR("B")="NO"
- +25 DO ^DIR
- +26 IF 'Y
- Begin DoDot:1
- +27 SET SCOUTFLD(.04)=1
- +28 SET SCX=$$ACOUTPT^SCAPMC20(DFN,"SCOUTFLD","SCBADOUT")
- +29 if SCX&'($GET(DGQUIET))
- DO EN^DDIOL("Patient Assigned to Primary Care, but no Team Assigned...")
- End DoDot:1
- GOTO END
- +30 SET DIC="^SCTM(404.51,"
- +31 SET DIC(0)="AEMQZ"
- +32 SET DIC("S")="IF $$ACTTM^SCMCTMU(Y,DT)&($P($G(^SCTM(404.51,Y,0)),U,5))"
- +33 ; - select from active teams that can be PC Teams
- +34 DO ^DIC
- +35 if Y<1
- GOTO END
- +36 SET SCTM=+Y
- +37 ;setup fields
- +38 SET SCTMFLDS(.02)=DT
- +39 ;primary care assignment
- SET SCTMFLDS(.08)=1
- +40 SET SCTMFLDS(.11)=$GET(DUZ,.5)
- +41 DO NOW^%DTC
- SET SCTMFLDS(.12)=%
- +42 IF $$ACPTTM^SCAPMC(DFN,SCTM,"SCTMFLDS",DT,"SCTPTME")
- Begin DoDot:1
- +43 if '$GET(DGQUIET)
- DO EN^DDIOL("...PC Team Assignment Made")
- End DoDot:1
- END ;
- +1 QUIT