MCWORKLD ;WISC/RMP-Workload reporting ;4/8/97 07:47
;;2.3;Medicine;**8**;09/13/1996
;Routine which delivers a Mail message to the
;specified Device(s) and Mailgroup(s) when a procedure
;with an assigned CPT code has been released with a signature
;
N CNT,DEVICE,MAILGRP,ARRAY
Q:$P($G(^MCAR(690.1,1,0)),U,7)'="Y" ;Check Workload toggle
Q:'($D(^MCAR(MCFILE,MCARGDA,0))#2) ;Check o node for G.P. patch
Q:$P($G(^MCAR(MCFILE,MCARGDA,"ES")),U,7)["S" ;Don't send a message
;for a superceded record
D TEXT(MCFILE,MCARGDA,.ARRAY) ;Check for completeness
Q:'$D(ARRAY)
;Device/Mailgroup parameter loading
I $D(^MCAR(690.1,1,1,0)) D
.S CNT=0
.F S CNT=$O(^MCAR(690.1,1,2,CNT)) Q:CNT'?1N.N D
..Q:'$D(^MCAR(690.1,1,2,CNT,0))
..N MCARCNT S MCARCNT=^MCAR(690.1,1,2,CNT,0)
..S DEVICE(CNT)=$P(^%ZIS(1,MCARCNT,0),U)
..Q
.Q
I $D(^MCAR(690.1,1,2,0)) D
.S CNT=0
.F S CNT=$O(^MCAR(690.1,1,1,CNT)) Q:CNT'?1N.N D
..Q:'$D(^MCAR(690.1,1,1,CNT,0))
..N MCARCNT S MCARCNT=^MCAR(690.1,1,1,CNT,0)
..S MAILGRP(CNT)=$P(^XMB(3.8,MCARCNT,0),U)
..Q
.Q
;Q:($G(DEVICE(1))=0)&($G(MAILGRP(1))=0)
Q:($D(DEVICE)=0)&($D(MAILGRP)=0)
; Mailman parameters
S XMSUB="Completed Coded Medicine Procedure"
S XMTEXT="ARRAY(",XMDUZ=DUZ,XMCHAN=""
S CNT=0 F S CNT=$O(DEVICE(CNT)) Q:CNT="" S XMY("D."_DEVICE(CNT))=""
S CNT=0 F S CNT=$O(MAILGRP(CNT)) Q:CNT="" S XMY("G."_MAILGRP(CNT))=""
D ^XMD
D KILL^XM
Q
;
TEXT(MCFILE,MCARGDA,ARRAY) ;
;Report variables:
;DFN -- Patient ID, pointer to the Patient file (2)
;PRID -- Provider ID, DUZ or pointer to the New Person file (200)
;PRNAME -- Provider Name
;PDATET -- Procedure Date/Time, DATE SIGNED
;CPT -- CPT code, Code associated throught the Procedure Term file
N PTMP,PRNAME,CPT,MCDATET,SSN
K ARRAY
S PRID=$P($G(^MCAR(MCFILE,MCARGDA,"ES")),U,4)
S FMDT=$P($G(^MCAR(MCFILE,MCARGDA,"ES")),U,6),Y=FMDT
S DFN=$$DFN(MCFILE,MCARGDA)
S CPT=$$CPT(MCFILE,MCARGDA)
I (PRID="")!(FMDT="")!(DFN="")!(CPT="") Q
D DD^%DT S MCDATET=Y
; ------------------------
; SSN = Enternal Format of the patients SSN.
; ------------------------
D DEM^VADPT S MCARNM=VADM(1),SSN=$P(VADM(2),U,2) D KVAR^VADPT
S PTMP=$P(^VA(200,PRID,0),U),PRNAME=$P(PTMP,",",2)_" "_$P(PTMP,",")
S ARRAY(1)="Patient: "_MCARNM
S ARRAY(2)="SSN: "_SSN
S ARRAY(3)="Procedure: "_CPT
S ARRAY(4)="Date/Time: "_MCDATET
S ARRAY(5)="Provider: "_PRNAME
Q
;
CPT(FILE,DA) ;
N TEMP,IEN,CPT,PRO
S CPT=""
S MCARP=$O(^MCAR(697.2,"B",$$MCPRO(FILE,DA),0))
S IEN=$O(^MCAR(694.8,"PS",MCARP,0))
;Q:IEN=""
I IEN]"",$D(^MCAR(694.8,IEN,1,0)) S TEMP=0,PRO=$P($G(^MCAR(694.8,IEN,0)),U) D
.F Q:CPT?1N.N S TEMP=$O(^MCAR(694.8,IEN,1,TEMP)) Q:TEMP'?1N.N D
..I $P($P(^(TEMP,0),U),";",2)["ICPT(" S CPT=$P($P(^(0),U),";")
..Q
.S CPT=PRO_" "_CPT ;V2.3, E3R 8219, JCC, 5/13/96
Q CPT
;
DFN(FILE,DA) ;
N TEMP
;S TEMP=$P(^DD(FILE,$$PATFLD(FILE,DA),0),U,4)
S TEMP=$$GET1^DID(FILE,$$PATFLD(FILE,DA),"","GLOBAL SUBSCRIPT LOCATION")
Q $P($G(^MCAR(FILE,MCARGDA,$P(TEMP,";"))),U,$P(TEMP,";",2))
;V2.3, FIX UNDEF, JCC, 5/21/96
PATFLD(FILE,DA) ;
N TEMP
S TEMP=$G(^MCAR(697.2,$O(^MCAR(697.2,"B",$$MCPRO(FILE,DA),0)),0))
Q $P(TEMP,U,12)
MCPRO(MCFILE,MCARGDA) ;694(0;3),699(0;12),699.5(0;6)
;HAVE MULTIPLE FILE 697.2 ENTRIES
I (MCFILE=694)!(MCFILE=699)!(MCFILE=699.5) Q $$MCP(MCFILE,MCARGDA) ;V2.3, CHGED SECOND 699 TO 699.5, JCC, 6/17/96
Q $P(^MCAR(697.2,$O(^MCAR(697.2,"C","MCAR("_MCFILE,0)),0),U)
MCP(MCFILE,MCARGDA) ;
Q $P(^MCAR(697.2,$P($G(^MCAR(MCFILE,MCARGDA,$$NODE(MCFILE))),U,$$PIECE(MCFILE)),0),U)
NODE(MCFILE) ;
Q $S(1:0) ;694&699&699.5 use the 0 node
PIECE(MCFILE) ;
Q $S(MCFILE=694:3,MCFILE=699:12,MCFILE=699.5:6,1:0)
WLTOG ;Medicine Workload reporting Toggle
;S DIE=690.1,DA=1,DR="6//"_$S($P($G(^MCAR(690.1,1,0)),U,7)="Y":"N",1:"Y"),DIC(0)="E" D ^DIE K DIE,DIC,DA,DR Q
D PARAM^MCU("6//"_$S($P($G(^MCAR(690.1,1,0)),U,7)="Y":"N",1:"Y"))
Q
WLMGP ;Medicine Workload Mailgroup recipients
;S DIE=690.1,DA=1,DR=7,DIC(0)="E" D ^DIE K DIC,DIE,DA,DR Q
D PARAM^MCU(7)
Q
WLDEV ;Medicine Workload Print Device selection
;S DIE=690.1,DA=1,DR=8,DIC(0)="E" D ^DIE K DIC,DIE,DA,DR Q
D PARAM^MCU(8)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCWORKLD 4231 printed Apr 09, 2024@21:17:22 Page 2
MCWORKLD ;WISC/RMP-Workload reporting ;4/8/97 07:47
+1 ;;2.3;Medicine;**8**;09/13/1996
+2 ;Routine which delivers a Mail message to the
+3 ;specified Device(s) and Mailgroup(s) when a procedure
+4 ;with an assigned CPT code has been released with a signature
+5 ;
+6 NEW CNT,DEVICE,MAILGRP,ARRAY
+7 ;Check Workload toggle
if $PIECE($GET(^MCAR(690.1,1,0)),U,7)'="Y"
QUIT
+8 ;Check o node for G.P. patch
if '($DATA(^MCAR(MCFILE,MCARGDA,0))#2)
QUIT
+9 ;Don't send a message
if $PIECE($GET(^MCAR(MCFILE,MCARGDA,"ES")),U,7)["S"
QUIT
+10 ;for a superceded record
+11 ;Check for completeness
DO TEXT(MCFILE,MCARGDA,.ARRAY)
+12 if '$DATA(ARRAY)
QUIT
+13 ;Device/Mailgroup parameter loading
+14 IF $DATA(^MCAR(690.1,1,1,0))
Begin DoDot:1
+15 SET CNT=0
+16 FOR
SET CNT=$ORDER(^MCAR(690.1,1,2,CNT))
if CNT'?1N.N
QUIT
Begin DoDot:2
+17 if '$DATA(^MCAR(690.1,1,2,CNT,0))
QUIT
+18 NEW MCARCNT
SET MCARCNT=^MCAR(690.1,1,2,CNT,0)
+19 SET DEVICE(CNT)=$PIECE(^%ZIS(1,MCARCNT,0),U)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 IF $DATA(^MCAR(690.1,1,2,0))
Begin DoDot:1
+23 SET CNT=0
+24 FOR
SET CNT=$ORDER(^MCAR(690.1,1,1,CNT))
if CNT'?1N.N
QUIT
Begin DoDot:2
+25 if '$DATA(^MCAR(690.1,1,1,CNT,0))
QUIT
+26 NEW MCARCNT
SET MCARCNT=^MCAR(690.1,1,1,CNT,0)
+27 SET MAILGRP(CNT)=$PIECE(^XMB(3.8,MCARCNT,0),U)
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 ;Q:($G(DEVICE(1))=0)&($G(MAILGRP(1))=0)
+31 if ($DATA(DEVICE)=0)&($DATA(MAILGRP)=0)
QUIT
+32 ; Mailman parameters
+33 SET XMSUB="Completed Coded Medicine Procedure"
+34 SET XMTEXT="ARRAY("
SET XMDUZ=DUZ
SET XMCHAN=""
+35 SET CNT=0
FOR
SET CNT=$ORDER(DEVICE(CNT))
if CNT=""
QUIT
SET XMY("D."_DEVICE(CNT))=""
+36 SET CNT=0
FOR
SET CNT=$ORDER(MAILGRP(CNT))
if CNT=""
QUIT
SET XMY("G."_MAILGRP(CNT))=""
+37 DO ^XMD
+38 DO KILL^XM
+39 QUIT
+40 ;
TEXT(MCFILE,MCARGDA,ARRAY) ;
+1 ;Report variables:
+2 ;DFN -- Patient ID, pointer to the Patient file (2)
+3 ;PRID -- Provider ID, DUZ or pointer to the New Person file (200)
+4 ;PRNAME -- Provider Name
+5 ;PDATET -- Procedure Date/Time, DATE SIGNED
+6 ;CPT -- CPT code, Code associated throught the Procedure Term file
+7 NEW PTMP,PRNAME,CPT,MCDATET,SSN
+8 KILL ARRAY
+9 SET PRID=$PIECE($GET(^MCAR(MCFILE,MCARGDA,"ES")),U,4)
+10 SET FMDT=$PIECE($GET(^MCAR(MCFILE,MCARGDA,"ES")),U,6)
SET Y=FMDT
+11 SET DFN=$$DFN(MCFILE,MCARGDA)
+12 SET CPT=$$CPT(MCFILE,MCARGDA)
+13 IF (PRID="")!(FMDT="")!(DFN="")!(CPT="")
QUIT
+14 DO DD^%DT
SET MCDATET=Y
+15 ; ------------------------
+16 ; SSN = Enternal Format of the patients SSN.
+17 ; ------------------------
+18 DO DEM^VADPT
SET MCARNM=VADM(1)
SET SSN=$PIECE(VADM(2),U,2)
DO KVAR^VADPT
+19 SET PTMP=$PIECE(^VA(200,PRID,0),U)
SET PRNAME=$PIECE(PTMP,",",2)_" "_$PIECE(PTMP,",")
+20 SET ARRAY(1)="Patient: "_MCARNM
+21 SET ARRAY(2)="SSN: "_SSN
+22 SET ARRAY(3)="Procedure: "_CPT
+23 SET ARRAY(4)="Date/Time: "_MCDATET
+24 SET ARRAY(5)="Provider: "_PRNAME
+25 QUIT
+26 ;
CPT(FILE,DA) ;
+1 NEW TEMP,IEN,CPT,PRO
+2 SET CPT=""
+3 SET MCARP=$ORDER(^MCAR(697.2,"B",$$MCPRO(FILE,DA),0))
+4 SET IEN=$ORDER(^MCAR(694.8,"PS",MCARP,0))
+5 ;Q:IEN=""
+6 IF IEN]""
IF $DATA(^MCAR(694.8,IEN,1,0))
SET TEMP=0
SET PRO=$PIECE($GET(^MCAR(694.8,IEN,0)),U)
Begin DoDot:1
+7 FOR
if CPT?1N.N
QUIT
SET TEMP=$ORDER(^MCAR(694.8,IEN,1,TEMP))
if TEMP'?1N.N
QUIT
Begin DoDot:2
+8 IF $PIECE($PIECE(^(TEMP,0),U),";",2)["ICPT("
SET CPT=$PIECE($PIECE(^(0),U),";")
+9 QUIT
End DoDot:2
+10 ;V2.3, E3R 8219, JCC, 5/13/96
SET CPT=PRO_" "_CPT
End DoDot:1
+11 QUIT CPT
+12 ;
DFN(FILE,DA) ;
+1 NEW TEMP
+2 ;S TEMP=$P(^DD(FILE,$$PATFLD(FILE,DA),0),U,4)
+3 SET TEMP=$$GET1^DID(FILE,$$PATFLD(FILE,DA),"","GLOBAL SUBSCRIPT LOCATION")
+4 QUIT $PIECE($GET(^MCAR(FILE,MCARGDA,$PIECE(TEMP,";"))),U,$PIECE(TEMP,";",2))
+5 ;V2.3, FIX UNDEF, JCC, 5/21/96
PATFLD(FILE,DA) ;
+1 NEW TEMP
+2 SET TEMP=$GET(^MCAR(697.2,$ORDER(^MCAR(697.2,"B",$$MCPRO(FILE,DA),0)),0))
+3 QUIT $PIECE(TEMP,U,12)
MCPRO(MCFILE,MCARGDA) ;694(0;3),699(0;12),699.5(0;6)
+1 ;HAVE MULTIPLE FILE 697.2 ENTRIES
+2 ;V2.3, CHGED SECOND 699 TO 699.5, JCC, 6/17/96
IF (MCFILE=694)!(MCFILE=699)!(MCFILE=699.5)
QUIT $$MCP(MCFILE,MCARGDA)
+3 QUIT $PIECE(^MCAR(697.2,$ORDER(^MCAR(697.2,"C","MCAR("_MCFILE,0)),0),U)
MCP(MCFILE,MCARGDA) ;
+1 QUIT $PIECE(^MCAR(697.2,$PIECE($GET(^MCAR(MCFILE,MCARGDA,$$NODE(MCFILE))),U,$$PIECE(MCFILE)),0),U)
NODE(MCFILE) ;
+1 ;694&699&699.5 use the 0 node
QUIT $SELECT(1:0)
PIECE(MCFILE) ;
+1 QUIT $SELECT(MCFILE=694:3,MCFILE=699:12,MCFILE=699.5:6,1:0)
WLTOG ;Medicine Workload reporting Toggle
+1 ;S DIE=690.1,DA=1,DR="6//"_$S($P($G(^MCAR(690.1,1,0)),U,7)="Y":"N",1:"Y"),DIC(0)="E" D ^DIE K DIE,DIC,DA,DR Q
+2 DO PARAM^MCU("6//"_$SELECT($PIECE($GET(^MCAR(690.1,1,0)),U,7)="Y":"N",1:"Y"))
+3 QUIT
WLMGP ;Medicine Workload Mailgroup recipients
+1 ;S DIE=690.1,DA=1,DR=7,DIC(0)="E" D ^DIE K DIC,DIE,DA,DR Q
+2 DO PARAM^MCU(7)
+3 QUIT
WLDEV ;Medicine Workload Print Device selection
+1 ;S DIE=690.1,DA=1,DR=8,DIC(0)="E" D ^DIE K DIC,DIE,DA,DR Q
+2 DO PARAM^MCU(8)
+3 QUIT
