WVRPCGF1 ;ISP/AGP - APIs for Clinical Reminders ;Oct 24, 2023@15:22:45
;;1.0;WOMEN'S HEALTH;**24,26,32**;Sep 30, 1998;Build 7
;
;
ACOPY(REF,OUTPUT) ;Copy all the descendants of the array reference into a linear
;array. REF is the starting array reference, for example A or
;^TMP("PXRM",$J). OUTPUT is the linear array for the output. It
;should be in the form of a closed root, i.e., A() or ^TMP($J,).
;Note OUTPUT cannot be used as the name of the output array.
N DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
I REF="" Q
S NL=0
S OROOT=$P(OUTPUT,")",1)
S PROOT=$P(REF,")",1)
;Build the root so we can tell when we are done.
S TEMP=$NA(@REF)
S ROOT=$P(TEMP,")",1)
S REF=$Q(@REF)
I REF'[ROOT Q
S DONE=0
F Q:(REF="")!(DONE) D
. S START=$F(REF,ROOT)
. S LEN=$L(REF)
. S IND=$E(REF,START,LEN)
. S NL=NL+1
. S OUT=OROOT_NL_")"
. S @OUT=PROOT_IND_"="_@REF
. S REF=$Q(@REF)
. I REF'[ROOT S DONE=1
Q
;
;build error message array
BLDMSG(PAT,SUBJ,NUM) ;
N CNT,ERR,GROUP,XMDUZ,XMSUB,XMTEXT,Y
K ^TMP("WV MSG",$J),XMY
S GROUP=$$GETMAILG^WVUTL4()
S CNT=0,XMDUZ=DUZ,XMSUB=SUBJ,XMTEXT="^TMP(""WV MSG"",$J,",XMY(DUZ)="",XMY("G."_GROUP)=""
S NUM=NUM+1,^TMP("WV MSG",$J,NUM,0)="Patient DFN: "_PAT
S NUM=NUM+1,^TMP("WV MSG",$J,NUM,0)="ERROR:"
D ACOPY("WVERR","ERR()")
S CNT=0 F S CNT=$O(ERR(CNT)) Q:CNT'>0 S NUM=NUM+1,^TMP("WV MSG",$J,NUM,0)=ERR(CNT)
S NUM=NUM+1,^TMP("WV MSG",$J,NUM,0)=""
S NUM=NUM+1,^TMP("WV MSG",$J,NUM,0)="INPUTS:"
K ERR
D ACOPY("INPUTS","ERR()")
D ^XMD
Q
;
MKWSDEV ;Make the WV WORKSTATION device.
N FDA,FDAIEN,MSG
;Make sure that the device does not get created more than once.
I +$$FIND1^DIC(3.5,"","MX","WV WORKSTATION")>0 Q
S FDA(3.5,"+1,",.01)="WV WORKSTATION" ;NAME
S FDA(3.5,"+1,",.02)="WV Workstation HFS Device" ;LOCATION OF TERMINAL
S FDA(3.5,"+1,",1)="WVWSD.DAT" ;$I
S FDA(3.5,"+1,",1.95)=0 ;SIGN-ON/SYSTEM DEVICE
S FDA(3.5,"+1,",2)="HFS" ;TYPE
S FDA(3.5,"+1,",3)=$$FIND1^DIC(3.2,"","MX","P-OTHER") ;SUBTYPE
S FDA(3.5,"+1,",4)=0 ;ASK DEVICE
S FDA(3.5,"+1,",5)=0 ;ASK PARAMETERS
S FDA(3.5,"+1,",5.1)=0 ;ASK HOST FILE
S FDA(3.5,"+1,",5.2)=0 ;ASK HFS I/O OPERATION
D UPDATE^DIE("","FDA","FDAIEN","MSG")
Q
;
;print api for CPRS view/print RPC
PRINT(RESULT,WVDFN,WVPURPTX) ;
N BY,DIWF
N %ZIS,BY,DC,DHD,DONE,FF,FILENAME,FILESPEC,FLDS,FR,GBL,HFNAME
N IND,IOP,NOW,PATH,VAR,WVPURP,SUCCESS,TO,UNIQN
S WVPURP=$O(^WV(790.404,"B",WVPURPTX,"")) I WVPURP'>0 Q
;D MKWSDEV^PXRMHOST
D MKWSDEV
;Set up the output file before DIP is called.
S PATH=$$PWD^%ZISH
S NOW=$$NOW^XLFDT
S NOW=$TR(NOW,".","")
S UNIQN=$J_NOW
S FILENAME="WVLETTER"_UNIQN_".DAT"
S HFNAME=PATH_FILENAME
S IOP="WV WORKSTATION;80"
S %ZIS("HFSMODE")="W"
S %ZIS("HFSNAME")=HFNAME
S DIWF="^WV(790.404,WVPURP,1,"
S DIWF(1)=790
S BY="INTERNAL(#.01)="_WVDFN
D GADD^WVUTL9(WVDFN) ;get current complete address
D SADD^WVUTL9(WVDFN) ;set complete address in File 790
D KVAR^WVUTL9 ;clean-up VADPT variables used
D EN2^DIWF
S GBL="^TMP(""WVLETTER"",$J,1,0)"
S GBL=$NA(@GBL)
K ^TMP("WVLETTER",$J)
S SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
;Look for a form feed, remove it and all subsequent lines.
S FF=$C(12)
I $G(VAR)["^" D
. S VAR=$NA(@VAR)
. S VAR=$P(VAR,")",1)
. S VAR=VAR_",IND,0)"
. S (DONE,IND)=0
. F Q:DONE S IND=$O(^TMP("WVLETTER",$J,IND)) Q:+IND=0 D
.. I ^TMP("WVLETTER",$J,IND,0)=FF S DONE=1 Q
.. S @VAR=^TMP("WVLETTER",$J,IND,0)
E D
. S (DONE,IND)=0
. F Q:DONE S IND=$O(^TMP("WVLETTER",$J,IND)) Q:+IND=0 D
.. S VAR(IND)=^TMP("WVLETTER",$J,IND,0)
.. I VAR(IND)=FF S DONE=1
S IND=0 F S IND=$O(^TMP("WVLETTER",$J,IND)) Q:IND'>0 D
.S RESULT(IND)=$G(^TMP("WVLETTER",$J,IND,0))
S RESULT(0)=1_U_WVPURPTX_" letter"
K ^TMP("WVLETTER",$J)
;Delete the host file.
S FILESPEC(FILENAME)=""
S SUCCESS=$$DEL^%ZISH(PATH,$NA(FILESPEC))
Q
;
NEXTPROC(DFN,TYPE) ;
N NAME,NODE
I TYPE="BR" S NODE=$P($G(^WV(790,DFN,0)),U,18,19)
I TYPE="CX" S NODE=$P($G(^WV(790,DFN,0)),U,11,12)
I +$P(NODE,U)'>0 Q ""
I +$P(NODE,U,2)'>0 Q ""
I TYPE="BR" S NAME=$P($G(^WV(790.51,$P(NODE,U),0)),U)
I TYPE="CX" S NAME=$P($G(^WV(790.5,$P(NODE,U),0)),U)
I NAME="" Q ""
Q NAME_U_$P(NODE,U,2)
;
VIEWDATA(RESULT,DATA,PAT,FINDVAL) ;
;FINDINGS("WOMEN'S HEALTH",FILE,CNT)=SUBSCRIPT_U_VALUE_U_PROMPT TYPE IEN_U_PROMPT SUBSCRIPT
N CNT,PKG,FILE,NODE,SUB,VALUE
S PKG="WOMEN'S HEALTH"
I '$D(DATA(PKG,790.4)),'$D(DATA(PKG,790.1)) Q
I $D(DATA(PKG,790.4)) D V7904(.RESULT,.DATA,PAT,FINDVAL)
I $D(DATA(PKG,790.1)) D V7901(.RESULT,.DATA,PAT,FINDVAL)
Q
;
V7904(RESULT,DATA,PAT,FINDVAL) ;
N INC,NODE,PKG,SUB,SUB1,VALUE
S PKG="WOMEN'S HEALTH"
S INC=0 F S INC=$O(DATA(PKG,790.4,INC)) Q:INC'>0 D
.S NODE=$G(DATA(PKG,790.4,INC))
.S SUB=$P(NODE,U),VALUE=$P(NODE,U,2),SUB1=$P(NODE,U,4)
.I SUB=".04" D PRINT^WVRPCGF1(.RESULT,PAT,VALUE) Q
.;I SUB="No Notifications" D
.;.S RESULT(0)=0_U_"Procedure(s) with no documented notification"
.;.D FNDWDATA^PXRMRPCG(.RESULT,PAT,IEN,FINDVAL,VALUE)
Q
;
V7901(RESULT,DATA,PAT,FINDVAL) ;
N CNT,DIR,DIAG,I,INC,NODE,PKG,SUB,SUB1,TCNT,TEXT,VALUE,X
S PKG="WOMEN'S HEALTH"
S INC=0 F S INC=$O(DATA(PKG,790.1,INC)) Q:INC'>0 D
.S NODE=$G(DATA(PKG,790.1,INC))
.S SUB=$P(NODE,U),VALUE=$P(NODE,U,2),SUB1=$P(NODE,U,4)
.I SUB="LAST THREE TRMTS" D Q
..K ^TMP("PXRMRPCG REPORT",$J)
..S DIR=1
..I $$LAST3^WVHS("PXRMRPCG REPORT",PAT,3,DIR)="" Q
..S RESULT(0)=1_U_"Last Three Breast Imaging Reports "_$S(DIR=1:"(Most Recent to Oldest)",1:"(Oldest to Most Recent)")
..S CNT=0,I=0 F S I=$O(^TMP("PXRMRPCG REPORT",$J,I)) Q:I'>0 D
...S CNT=CNT+1,RESULT(CNT)=$G(^TMP("PXRMRPCG REPORT",$J,I,0))
.I SUB=.01 D Q
..S CNT=0
..;S RESULT(0)=1_U
..S RESULT(0)=1_U_"Open Breast Imaging (Oldest to Most Recent)"
..F X=1:1:$L(FINDVAL,":") D
...K TEXT
...;S TCNT=0
...D GETTEST(+$P(FINDVAL,":",X),.TEXT,.DIAG)
...I X>1 S CNT=CNT+1,RESULT(CNT)="",CNT=CNT+1,RESULT(CNT)="----------------------------------------------------------",CNT=CNT+1,RESULT(CNT)=""
...S TCNT=0 F S TCNT=$O(TEXT(TCNT)) Q:TCNT'>0 S CNT=CNT+1,RESULT(CNT)=TEXT(TCNT)
...S CNT=CNT+1,RESULT(CNT)=""
Q
;
GETWVP(DFN,ITEM,TEXT) ;
N ACCESS,CNT,DTE,DATE,DIAGNS,ERROR,FUDATE,ID,NODE,PREVDT,PREVIEN,PREVDX,SECDX,TCNT,TEMP
N WVIENS,WVNTXT,WVRPTIEN,WVSECDXS,X
S NODE=$G(^WV(790.1,+ITEM,0))
D RADCASE^WVALERTR(+ITEM,.DIAGNS,.WVIENS,.WVRPTIEN,.WVSECDXS)
S TCNT=0,DTE=0
S ACCESS=$P(NODE,U),TCNT=TCNT+1,TEXT(TCNT)="Accession #: "_ACCESS
S TEMP=$P(NODE,U,4) I TEMP'="" D
.S TCNT=TCNT+1,TEXT(TCNT)="Procedure: "_$P($G(^WV(790.2,TEMP,0)),U)
S TEMP=$P(NODE,U,12) I TEMP'="" D
.S DTE=TEMP
.S TCNT=TCNT+1,TEXT(TCNT)="Date of Procedure: "_$$FMTE^XLFDT(TEMP)
I $P(NODE,U,14)="e" D Q
.S TCNT=TCNT+1,TEXT(TCNT)="Outside Procedure marked ENTER IN ERROR"
S TCNT=TCNT+1,TEXT(TCNT)=""
S TEMP=$P(NODE,U,5) I TEMP'="" D
.S TEMP=$$RETBIRAD($P($G(^WV(790.31,TEMP,0)),U),DTE)
.S TCNT=TCNT+1,TEXT(TCNT)="Primary Result: "_TEMP
I $D(WVSECDXS)>1 D
.S SECDX="" F S SECDX=$O(WVSECDXS(SECDX)) Q:SECDX="" D
..S TCNT=TCNT+1,TEXT(TCNT)="Secondary Result(s): "_SECDX
;AGP TODO BEGIN display previous diagnosis if set
I $D(^WV(790.1,+ITEM,11,"D")) D
.S TCNT=TCNT+1,TEXT(TCNT)="Radiology report changed; prior report result was:"
.S PREVDT=""
.F S PREVDT=$O(^WV(790.1,+ITEM,11,"D",PREVDT)) Q:PREVDT="" D
..S PREVIEN=0
..F S PREVIEN=$O(^WV(790.1,+ITEM,11,"D",PREVDT,PREVIEN)) Q:PREVIEN="" D
...S PREVDX=+$P($G(^WV(790.1,+ITEM,11,PREVIEN,0)),U) I PREVDX=0 Q
...S TEMP=$P($G(^WV(790.31,PREVDX,0)),U)
...S TCNT=TCNT+1,TEXT(TCNT)=TEMP_" changed on "_$$FMTE^XLFDT(PREVDT)
;AGP TODO END
S TCNT=TCNT+1,TEXT(TCNT)=""
I +$P(NODE,U,36)=1 S TCNT=TCNT+1,TEXT(TCNT)="Outside Report: True"
I +$P(NODE,U,36)'=1 D
.S TCNT=TCNT+1,TEXT(TCNT)="Radiology Case#: "_$P(NODE,U,15)
.S TCNT=TCNT+1,TEXT(TCNT)="Provider: "_$S($P(NODE,U,7)>0:$$GET1^DIQ(200,$P(NODE,U,7),.01),1:"None define")
I $G(^WV(790.1,+ITEM,3))'="" S TCNT=TCNT+1,TEXT(TCNT)="Procedure Comments: "_$G(^WV(790.1,+ITEM,3))
;
I $D(^WV(790.1,+ITEM,10,"DATE")) D
.S TCNT=TCNT+1,TEXT(TCNT)=""
.S DATE=0 F S DATE=$O(^WV(790.1,+ITEM,10,"DATE",DATE)) Q:DATE'>0 D
..S TCNT=TCNT+1,TEXT(TCNT)="Review of recommendations done on "_$$FMTE^XLFDT(DATE)
..S TEMP="" F S TEMP=$O(^WV(790.1,+ITEM,10,"DATE",DATE,TEMP)) Q:TEMP="" D
...S TCNT=TCNT+1,TEXT(TCNT)=TEMP
...S ID=$O(^WV(790.1,+ITEM,10,"DATE",DATE,TEMP,"")) Q:ID=""
...S ERROR=$S($P($G(^WV(790.1,+ITEM,10,ID,0)),U,5)="Y":1,1:0)
...S FUDATE=+$P($G(^WV(790.1,+ITEM,10,ID,0)),U,6)
...I FUDATE>0 S TEXT(TCNT)=TEXT(TCNT)_" by "_$$FMTE^XLFDT(FUDATE)
...I ERROR S TEXT(TCNT)=TEXT(TCNT)_" marked ENTER IN ERROR"
...I 'ERROR,$G(^WV(790.1,+ITEM,10,ID,1))'="" S TCNT=TCNT+1,TEXT(TCNT)="Comment: "_$G(^WV(790.1,+ITEM,10,ID,1))
;
D GETWVN(DFN,ACCESS,.WVNTXT)
S TCNT=TCNT+1,TEXT(TCNT)=""
S CNT=0 F S CNT=$O(WVNTXT(CNT)) Q:CNT'>0 S TCNT=TCNT+1,TEXT(TCNT)=WVNTXT(CNT)
Q
;
GETWVN(DFN,ITEM,TEXT) ;
N DATE,IEN,ERROR,FIRST,METHOD,NAME,NODE,PURIEN,PUR,TCNT,TEMP,WHO
S TCNT=0,FIRST=1
S TCNT=TCNT+1,TEXT(TCNT)="Prior Patient communication details:"
S IEN=0 F S IEN=$O(^WV(790.4,"C",ITEM,IEN)) Q:IEN'>0 D
.S NODE=$G(^WV(790.4,IEN,0))
.I $P(NODE,U,14)="e" Q
.S PURIEN=$P(NODE,U,4) Q:PURIEN'>0
.S PUR=$P($G(^WV(790.404,PURIEN,0)),U)
.S TEMP=$P(NODE,U,3) I TEMP="" Q
.I TEMP'="" S NAME=$P($G(^WV(790.403,TEMP,0)),U)
.S DATE=+$P(NODE,U,8)
.I $P($G(^WV(790.4,IEN,1)),U)'="" D Q
..;I +DATE>0 S METHOD(NAME)=U_$$FMTE^XLFDT(DATE) Q
..;S NODE=$G(^WV(790.4,IEN,1)) I NODE'=U S TCNT=TCNT+1,TEXT(TCNT)="Communication detail: Spoke to "_$P(NODE,U)_" on "_$$FMTE^XLFDT($P(NODE,U,2))
..;S NODE=$G(^WV(790.4,IEN,1)) I NODE'=U S TCNT=TCNT+1,TEXT(TCNT)="Spoke to "_$P(NODE,U)_" on "_$$FMTE^XLFDT($P(NODE,U,2)) Q
..S NODE=$G(^WV(790.4,IEN,1)) I NODE'=U S METHOD("Spoke to "_$P(NODE,U)_" on "_$$FMTE^XLFDT($P(NODE,U,2)))="" Q
..;S TCNT=TCNT+1,TEXT(TCNT)=NAME_$S(DATE>0:" "_$$FMTE^XLFDT(DATE),1:"")
..S METHOD(NAME_$S(DATE>0:" "_$$FMTE^XLFDT(DATE),1:""))=""
.;S TCNT=TCNT+1,TEXT(TCNT)=NAME_$S(DATE>0:" "_$$FMTE^XLFDT(DATE),1:"")
.S METHOD(NAME_$S(DATE>0:" "_$$FMTE^XLFDT(DATE),1:""))=""
S TEMP="" F S TEMP=$O(METHOD(TEMP)) Q:TEMP="" D
.S TCNT=TCNT+1,TEXT(TCNT)=TEMP
I TCNT=1 S TCNT=TCNT+1,TEXT(TCNT)="None on file"
Q
;
BRNEEDS(RESULT,BDT,EDT,TEST) ;
N DATE,END,PAT,PROC
S PROC=$O(^WV(790.51,"B",TEST,"")) Q:PROC'>0
S DATE=$S(BDT>0:BDT,1:0)
S END=$S(EDT>0:EDT,1:DT)
F S DATE=$O(^WV(790,"BRNEEDS",PROC,DATE)) Q:DATE'>0!(DATE'<END) D
.S PAT="" F S PAT=$O(^WV(790,"BRNEEDS",PROC,DATE,PAT)) Q:PAT'>0 S RESULT(PAT)=DATE
Q
;
GETTEST(WVIEN,TEXT,DIAG) ;
N Y
K ^TMP("WV RPT",$J)
D EN^WVALERTR(+WVIEN,.DIAG)
I '$D(^TMP("WV RPT",$J)) S TEXT(1)="No Imaging found in Radiology Package" Q
S Y=0 F S Y=$O(^TMP("WV RPT",$J,Y)) Q:Y'>0 S INC=INC+1,TEXT(INC)=$G(^TMP("WV RPT",$J,Y,0))
K ^TMP("WV RPT",$J)
Q
;
SETOPEN(DA,VALUES) ;
I +VALUES(1)'>0 Q 0
I VALUES(2)="" Q 0
I VALUES(3)="" Q 0
I VALUES(4)'="o" Q 0
Q 1
;
KILLOPEN(DA,VALUES) ;
I +VALUES(1)'>0 Q 1
I VALUES(2)="" Q 1
I VALUES(3)="" Q 1
I VALUES(4)'="o" Q 1
Q 0
;
RETBIRAD(CODE,PDTE) ;
N DTE,WVDATES
I PDTE=0 Q CODE
;I '$$INSTALDT^XPDUTL("WV*1.0*32",.WVDATES) Q CODE
I '$$INSTALDT^XPDUTL("RA*5.0*206",.WVDATES) Q CODE
I CODE'="BI-RADS CATEGORY 0 Need Additional Imaging Evaluation" Q CODE
S DTE=+$O(WVDATES("A"),-1) I DTE=0 Q CODE
I PDTE<DTE S CODE="BI-RADS CATEGORY 0"
Q CODE
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVRPCGF1 11605 printed Sep 23, 2025@20:23:56 Page 2
WVRPCGF1 ;ISP/AGP - APIs for Clinical Reminders ;Oct 24, 2023@15:22:45
+1 ;;1.0;WOMEN'S HEALTH;**24,26,32**;Sep 30, 1998;Build 7
+2 ;
+3 ;
ACOPY(REF,OUTPUT) ;Copy all the descendants of the array reference into a linear
+1 ;array. REF is the starting array reference, for example A or
+2 ;^TMP("PXRM",$J). OUTPUT is the linear array for the output. It
+3 ;should be in the form of a closed root, i.e., A() or ^TMP($J,).
+4 ;Note OUTPUT cannot be used as the name of the output array.
+5 NEW DONE,IND,LEN,NL,OROOT,OUT,PROOT,ROOT,START,TEMP
+6 IF REF=""
QUIT
+7 SET NL=0
+8 SET OROOT=$PIECE(OUTPUT,")",1)
+9 SET PROOT=$PIECE(REF,")",1)
+10 ;Build the root so we can tell when we are done.
+11 SET TEMP=$NAME(@REF)
+12 SET ROOT=$PIECE(TEMP,")",1)
+13 SET REF=$QUERY(@REF)
+14 IF REF'[ROOT
QUIT
+15 SET DONE=0
+16 FOR
if (REF="")!(DONE)
QUIT
Begin DoDot:1
+17 SET START=$FIND(REF,ROOT)
+18 SET LEN=$LENGTH(REF)
+19 SET IND=$EXTRACT(REF,START,LEN)
+20 SET NL=NL+1
+21 SET OUT=OROOT_NL_")"
+22 SET @OUT=PROOT_IND_"="_@REF
+23 SET REF=$QUERY(@REF)
+24 IF REF'[ROOT
SET DONE=1
End DoDot:1
+25 QUIT
+26 ;
+27 ;build error message array
BLDMSG(PAT,SUBJ,NUM) ;
+1 NEW CNT,ERR,GROUP,XMDUZ,XMSUB,XMTEXT,Y
+2 KILL ^TMP("WV MSG",$JOB),XMY
+3 SET GROUP=$$GETMAILG^WVUTL4()
+4 SET CNT=0
SET XMDUZ=DUZ
SET XMSUB=SUBJ
SET XMTEXT="^TMP(""WV MSG"",$J,"
SET XMY(DUZ)=""
SET XMY("G."_GROUP)=""
+5 SET NUM=NUM+1
SET ^TMP("WV MSG",$JOB,NUM,0)="Patient DFN: "_PAT
+6 SET NUM=NUM+1
SET ^TMP("WV MSG",$JOB,NUM,0)="ERROR:"
+7 DO ACOPY("WVERR","ERR()")
+8 SET CNT=0
FOR
SET CNT=$ORDER(ERR(CNT))
if CNT'>0
QUIT
SET NUM=NUM+1
SET ^TMP("WV MSG",$JOB,NUM,0)=ERR(CNT)
+9 SET NUM=NUM+1
SET ^TMP("WV MSG",$JOB,NUM,0)=""
+10 SET NUM=NUM+1
SET ^TMP("WV MSG",$JOB,NUM,0)="INPUTS:"
+11 KILL ERR
+12 DO ACOPY("INPUTS","ERR()")
+13 DO ^XMD
+14 QUIT
+15 ;
MKWSDEV ;Make the WV WORKSTATION device.
+1 NEW FDA,FDAIEN,MSG
+2 ;Make sure that the device does not get created more than once.
+3 IF +$$FIND1^DIC(3.5,"","MX","WV WORKSTATION")>0
QUIT
+4 ;NAME
SET FDA(3.5,"+1,",.01)="WV WORKSTATION"
+5 ;LOCATION OF TERMINAL
SET FDA(3.5,"+1,",.02)="WV Workstation HFS Device"
+6 ;$I
SET FDA(3.5,"+1,",1)="WVWSD.DAT"
+7 ;SIGN-ON/SYSTEM DEVICE
SET FDA(3.5,"+1,",1.95)=0
+8 ;TYPE
SET FDA(3.5,"+1,",2)="HFS"
+9 ;SUBTYPE
SET FDA(3.5,"+1,",3)=$$FIND1^DIC(3.2,"","MX","P-OTHER")
+10 ;ASK DEVICE
SET FDA(3.5,"+1,",4)=0
+11 ;ASK PARAMETERS
SET FDA(3.5,"+1,",5)=0
+12 ;ASK HOST FILE
SET FDA(3.5,"+1,",5.1)=0
+13 ;ASK HFS I/O OPERATION
SET FDA(3.5,"+1,",5.2)=0
+14 DO UPDATE^DIE("","FDA","FDAIEN","MSG")
+15 QUIT
+16 ;
+17 ;print api for CPRS view/print RPC
PRINT(RESULT,WVDFN,WVPURPTX) ;
+1 NEW BY,DIWF
+2 NEW %ZIS,BY,DC,DHD,DONE,FF,FILENAME,FILESPEC,FLDS,FR,GBL,HFNAME
+3 NEW IND,IOP,NOW,PATH,VAR,WVPURP,SUCCESS,TO,UNIQN
+4 SET WVPURP=$ORDER(^WV(790.404,"B",WVPURPTX,""))
IF WVPURP'>0
QUIT
+5 ;D MKWSDEV^PXRMHOST
+6 DO MKWSDEV
+7 ;Set up the output file before DIP is called.
+8 SET PATH=$$PWD^%ZISH
+9 SET NOW=$$NOW^XLFDT
+10 SET NOW=$TRANSLATE(NOW,".","")
+11 SET UNIQN=$JOB_NOW
+12 SET FILENAME="WVLETTER"_UNIQN_".DAT"
+13 SET HFNAME=PATH_FILENAME
+14 SET IOP="WV WORKSTATION;80"
+15 SET %ZIS("HFSMODE")="W"
+16 SET %ZIS("HFSNAME")=HFNAME
+17 SET DIWF="^WV(790.404,WVPURP,1,"
+18 SET DIWF(1)=790
+19 SET BY="INTERNAL(#.01)="_WVDFN
+20 ;get current complete address
DO GADD^WVUTL9(WVDFN)
+21 ;set complete address in File 790
DO SADD^WVUTL9(WVDFN)
+22 ;clean-up VADPT variables used
DO KVAR^WVUTL9
+23 DO EN2^DIWF
+24 SET GBL="^TMP(""WVLETTER"",$J,1,0)"
+25 SET GBL=$NAME(@GBL)
+26 KILL ^TMP("WVLETTER",$JOB)
+27 SET SUCCESS=$$FTG^%ZISH(PATH,FILENAME,GBL,3)
+28 ;Look for a form feed, remove it and all subsequent lines.
+29 SET FF=$CHAR(12)
+30 IF $GET(VAR)["^"
Begin DoDot:1
+31 SET VAR=$NAME(@VAR)
+32 SET VAR=$PIECE(VAR,")",1)
+33 SET VAR=VAR_",IND,0)"
+34 SET (DONE,IND)=0
+35 FOR
if DONE
QUIT
SET IND=$ORDER(^TMP("WVLETTER",$JOB,IND))
if +IND=0
QUIT
Begin DoDot:2
+36 IF ^TMP("WVLETTER",$JOB,IND,0)=FF
SET DONE=1
QUIT
+37 SET @VAR=^TMP("WVLETTER",$JOB,IND,0)
End DoDot:2
End DoDot:1
+38 IF '$TEST
Begin DoDot:1
+39 SET (DONE,IND)=0
+40 FOR
if DONE
QUIT
SET IND=$ORDER(^TMP("WVLETTER",$JOB,IND))
if +IND=0
QUIT
Begin DoDot:2
+41 SET VAR(IND)=^TMP("WVLETTER",$JOB,IND,0)
+42 IF VAR(IND)=FF
SET DONE=1
End DoDot:2
End DoDot:1
+43 SET IND=0
FOR
SET IND=$ORDER(^TMP("WVLETTER",$JOB,IND))
if IND'>0
QUIT
Begin DoDot:1
+44 SET RESULT(IND)=$GET(^TMP("WVLETTER",$JOB,IND,0))
End DoDot:1
+45 SET RESULT(0)=1_U_WVPURPTX_" letter"
+46 KILL ^TMP("WVLETTER",$JOB)
+47 ;Delete the host file.
+48 SET FILESPEC(FILENAME)=""
+49 SET SUCCESS=$$DEL^%ZISH(PATH,$NAME(FILESPEC))
+50 QUIT
+51 ;
NEXTPROC(DFN,TYPE) ;
+1 NEW NAME,NODE
+2 IF TYPE="BR"
SET NODE=$PIECE($GET(^WV(790,DFN,0)),U,18,19)
+3 IF TYPE="CX"
SET NODE=$PIECE($GET(^WV(790,DFN,0)),U,11,12)
+4 IF +$PIECE(NODE,U)'>0
QUIT ""
+5 IF +$PIECE(NODE,U,2)'>0
QUIT ""
+6 IF TYPE="BR"
SET NAME=$PIECE($GET(^WV(790.51,$PIECE(NODE,U),0)),U)
+7 IF TYPE="CX"
SET NAME=$PIECE($GET(^WV(790.5,$PIECE(NODE,U),0)),U)
+8 IF NAME=""
QUIT ""
+9 QUIT NAME_U_$PIECE(NODE,U,2)
+10 ;
VIEWDATA(RESULT,DATA,PAT,FINDVAL) ;
+1 ;FINDINGS("WOMEN'S HEALTH",FILE,CNT)=SUBSCRIPT_U_VALUE_U_PROMPT TYPE IEN_U_PROMPT SUBSCRIPT
+2 NEW CNT,PKG,FILE,NODE,SUB,VALUE
+3 SET PKG="WOMEN'S HEALTH"
+4 IF '$DATA(DATA(PKG,790.4))
IF '$DATA(DATA(PKG,790.1))
QUIT
+5 IF $DATA(DATA(PKG,790.4))
DO V7904(.RESULT,.DATA,PAT,FINDVAL)
+6 IF $DATA(DATA(PKG,790.1))
DO V7901(.RESULT,.DATA,PAT,FINDVAL)
+7 QUIT
+8 ;
V7904(RESULT,DATA,PAT,FINDVAL) ;
+1 NEW INC,NODE,PKG,SUB,SUB1,VALUE
+2 SET PKG="WOMEN'S HEALTH"
+3 SET INC=0
FOR
SET INC=$ORDER(DATA(PKG,790.4,INC))
if INC'>0
QUIT
Begin DoDot:1
+4 SET NODE=$GET(DATA(PKG,790.4,INC))
+5 SET SUB=$PIECE(NODE,U)
SET VALUE=$PIECE(NODE,U,2)
SET SUB1=$PIECE(NODE,U,4)
+6 IF SUB=".04"
DO PRINT^WVRPCGF1(.RESULT,PAT,VALUE)
QUIT
+7 ;I SUB="No Notifications" D
+8 ;.S RESULT(0)=0_U_"Procedure(s) with no documented notification"
+9 ;.D FNDWDATA^PXRMRPCG(.RESULT,PAT,IEN,FINDVAL,VALUE)
End DoDot:1
+10 QUIT
+11 ;
V7901(RESULT,DATA,PAT,FINDVAL) ;
+1 NEW CNT,DIR,DIAG,I,INC,NODE,PKG,SUB,SUB1,TCNT,TEXT,VALUE,X
+2 SET PKG="WOMEN'S HEALTH"
+3 SET INC=0
FOR
SET INC=$ORDER(DATA(PKG,790.1,INC))
if INC'>0
QUIT
Begin DoDot:1
+4 SET NODE=$GET(DATA(PKG,790.1,INC))
+5 SET SUB=$PIECE(NODE,U)
SET VALUE=$PIECE(NODE,U,2)
SET SUB1=$PIECE(NODE,U,4)
+6 IF SUB="LAST THREE TRMTS"
Begin DoDot:2
+7 KILL ^TMP("PXRMRPCG REPORT",$JOB)
+8 SET DIR=1
+9 IF $$LAST3^WVHS("PXRMRPCG REPORT",PAT,3,DIR)=""
QUIT
+10 SET RESULT(0)=1_U_"Last Three Breast Imaging Reports "_$SELECT(DIR=1:"(Most Recent to Oldest)",1:"(Oldest to Most Recent)")
+11 SET CNT=0
SET I=0
FOR
SET I=$ORDER(^TMP("PXRMRPCG REPORT",$JOB,I))
if I'>0
QUIT
Begin DoDot:3
+12 SET CNT=CNT+1
SET RESULT(CNT)=$GET(^TMP("PXRMRPCG REPORT",$JOB,I,0))
End DoDot:3
End DoDot:2
QUIT
+13 IF SUB=.01
Begin DoDot:2
+14 SET CNT=0
+15 ;S RESULT(0)=1_U
+16 SET RESULT(0)=1_U_"Open Breast Imaging (Oldest to Most Recent)"
+17 FOR X=1:1:$LENGTH(FINDVAL,":")
Begin DoDot:3
+18 KILL TEXT
+19 ;S TCNT=0
+20 DO GETTEST(+$PIECE(FINDVAL,":",X),.TEXT,.DIAG)
+21 IF X>1
SET CNT=CNT+1
SET RESULT(CNT)=""
SET CNT=CNT+1
SET RESULT(CNT)="----------------------------------------------------------"
SET CNT=CNT+1
SET RESULT(CNT)=""
+22 SET TCNT=0
FOR
SET TCNT=$ORDER(TEXT(TCNT))
if TCNT'>0
QUIT
SET CNT=CNT+1
SET RESULT(CNT)=TEXT(TCNT)
+23 SET CNT=CNT+1
SET RESULT(CNT)=""
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+24 QUIT
+25 ;
GETWVP(DFN,ITEM,TEXT) ;
+1 NEW ACCESS,CNT,DTE,DATE,DIAGNS,ERROR,FUDATE,ID,NODE,PREVDT,PREVIEN,PREVDX,SECDX,TCNT,TEMP
+2 NEW WVIENS,WVNTXT,WVRPTIEN,WVSECDXS,X
+3 SET NODE=$GET(^WV(790.1,+ITEM,0))
+4 DO RADCASE^WVALERTR(+ITEM,.DIAGNS,.WVIENS,.WVRPTIEN,.WVSECDXS)
+5 SET TCNT=0
SET DTE=0
+6 SET ACCESS=$PIECE(NODE,U)
SET TCNT=TCNT+1
SET TEXT(TCNT)="Accession #: "_ACCESS
+7 SET TEMP=$PIECE(NODE,U,4)
IF TEMP'=""
Begin DoDot:1
+8 SET TCNT=TCNT+1
SET TEXT(TCNT)="Procedure: "_$PIECE($GET(^WV(790.2,TEMP,0)),U)
End DoDot:1
+9 SET TEMP=$PIECE(NODE,U,12)
IF TEMP'=""
Begin DoDot:1
+10 SET DTE=TEMP
+11 SET TCNT=TCNT+1
SET TEXT(TCNT)="Date of Procedure: "_$$FMTE^XLFDT(TEMP)
End DoDot:1
+12 IF $PIECE(NODE,U,14)="e"
Begin DoDot:1
+13 SET TCNT=TCNT+1
SET TEXT(TCNT)="Outside Procedure marked ENTER IN ERROR"
End DoDot:1
QUIT
+14 SET TCNT=TCNT+1
SET TEXT(TCNT)=""
+15 SET TEMP=$PIECE(NODE,U,5)
IF TEMP'=""
Begin DoDot:1
+16 SET TEMP=$$RETBIRAD($PIECE($GET(^WV(790.31,TEMP,0)),U),DTE)
+17 SET TCNT=TCNT+1
SET TEXT(TCNT)="Primary Result: "_TEMP
End DoDot:1
+18 IF $DATA(WVSECDXS)>1
Begin DoDot:1
+19 SET SECDX=""
FOR
SET SECDX=$ORDER(WVSECDXS(SECDX))
if SECDX=""
QUIT
Begin DoDot:2
+20 SET TCNT=TCNT+1
SET TEXT(TCNT)="Secondary Result(s): "_SECDX
End DoDot:2
End DoDot:1
+21 ;AGP TODO BEGIN display previous diagnosis if set
+22 IF $DATA(^WV(790.1,+ITEM,11,"D"))
Begin DoDot:1
+23 SET TCNT=TCNT+1
SET TEXT(TCNT)="Radiology report changed; prior report result was:"
+24 SET PREVDT=""
+25 FOR
SET PREVDT=$ORDER(^WV(790.1,+ITEM,11,"D",PREVDT))
if PREVDT=""
QUIT
Begin DoDot:2
+26 SET PREVIEN=0
+27 FOR
SET PREVIEN=$ORDER(^WV(790.1,+ITEM,11,"D",PREVDT,PREVIEN))
if PREVIEN=""
QUIT
Begin DoDot:3
+28 SET PREVDX=+$PIECE($GET(^WV(790.1,+ITEM,11,PREVIEN,0)),U)
IF PREVDX=0
QUIT
+29 SET TEMP=$PIECE($GET(^WV(790.31,PREVDX,0)),U)
+30 SET TCNT=TCNT+1
SET TEXT(TCNT)=TEMP_" changed on "_$$FMTE^XLFDT(PREVDT)
End DoDot:3
End DoDot:2
End DoDot:1
+31 ;AGP TODO END
+32 SET TCNT=TCNT+1
SET TEXT(TCNT)=""
+33 IF +$PIECE(NODE,U,36)=1
SET TCNT=TCNT+1
SET TEXT(TCNT)="Outside Report: True"
+34 IF +$PIECE(NODE,U,36)'=1
Begin DoDot:1
+35 SET TCNT=TCNT+1
SET TEXT(TCNT)="Radiology Case#: "_$PIECE(NODE,U,15)
+36 SET TCNT=TCNT+1
SET TEXT(TCNT)="Provider: "_$SELECT($PIECE(NODE,U,7)>0:$$GET1^DIQ(200,$PIECE(NODE,U,7),.01),1:"None define")
End DoDot:1
+37 IF $GET(^WV(790.1,+ITEM,3))'=""
SET TCNT=TCNT+1
SET TEXT(TCNT)="Procedure Comments: "_$GET(^WV(790.1,+ITEM,3))
+38 ;
+39 IF $DATA(^WV(790.1,+ITEM,10,"DATE"))
Begin DoDot:1
+40 SET TCNT=TCNT+1
SET TEXT(TCNT)=""
+41 SET DATE=0
FOR
SET DATE=$ORDER(^WV(790.1,+ITEM,10,"DATE",DATE))
if DATE'>0
QUIT
Begin DoDot:2
+42 SET TCNT=TCNT+1
SET TEXT(TCNT)="Review of recommendations done on "_$$FMTE^XLFDT(DATE)
+43 SET TEMP=""
FOR
SET TEMP=$ORDER(^WV(790.1,+ITEM,10,"DATE",DATE,TEMP))
if TEMP=""
QUIT
Begin DoDot:3
+44 SET TCNT=TCNT+1
SET TEXT(TCNT)=TEMP
+45 SET ID=$ORDER(^WV(790.1,+ITEM,10,"DATE",DATE,TEMP,""))
if ID=""
QUIT
+46 SET ERROR=$SELECT($PIECE($GET(^WV(790.1,+ITEM,10,ID,0)),U,5)="Y":1,1:0)
+47 SET FUDATE=+$PIECE($GET(^WV(790.1,+ITEM,10,ID,0)),U,6)
+48 IF FUDATE>0
SET TEXT(TCNT)=TEXT(TCNT)_" by "_$$FMTE^XLFDT(FUDATE)
+49 IF ERROR
SET TEXT(TCNT)=TEXT(TCNT)_" marked ENTER IN ERROR"
+50 IF 'ERROR
IF $GET(^WV(790.1,+ITEM,10,ID,1))'=""
SET TCNT=TCNT+1
SET TEXT(TCNT)="Comment: "_$GET(^WV(790.1,+ITEM,10,ID,1))
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 DO GETWVN(DFN,ACCESS,.WVNTXT)
+53 SET TCNT=TCNT+1
SET TEXT(TCNT)=""
+54 SET CNT=0
FOR
SET CNT=$ORDER(WVNTXT(CNT))
if CNT'>0
QUIT
SET TCNT=TCNT+1
SET TEXT(TCNT)=WVNTXT(CNT)
+55 QUIT
+56 ;
GETWVN(DFN,ITEM,TEXT) ;
+1 NEW DATE,IEN,ERROR,FIRST,METHOD,NAME,NODE,PURIEN,PUR,TCNT,TEMP,WHO
+2 SET TCNT=0
SET FIRST=1
+3 SET TCNT=TCNT+1
SET TEXT(TCNT)="Prior Patient communication details:"
+4 SET IEN=0
FOR
SET IEN=$ORDER(^WV(790.4,"C",ITEM,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+5 SET NODE=$GET(^WV(790.4,IEN,0))
+6 IF $PIECE(NODE,U,14)="e"
QUIT
+7 SET PURIEN=$PIECE(NODE,U,4)
if PURIEN'>0
QUIT
+8 SET PUR=$PIECE($GET(^WV(790.404,PURIEN,0)),U)
+9 SET TEMP=$PIECE(NODE,U,3)
IF TEMP=""
QUIT
+10 IF TEMP'=""
SET NAME=$PIECE($GET(^WV(790.403,TEMP,0)),U)
+11 SET DATE=+$PIECE(NODE,U,8)
+12 IF $PIECE($GET(^WV(790.4,IEN,1)),U)'=""
Begin DoDot:2
+13 ;I +DATE>0 S METHOD(NAME)=U_$$FMTE^XLFDT(DATE) Q
+14 ;S NODE=$G(^WV(790.4,IEN,1)) I NODE'=U S TCNT=TCNT+1,TEXT(TCNT)="Communication detail: Spoke to "_$P(NODE,U)_" on "_$$FMTE^XLFDT($P(NODE,U,2))
+15 ;S NODE=$G(^WV(790.4,IEN,1)) I NODE'=U S TCNT=TCNT+1,TEXT(TCNT)="Spoke to "_$P(NODE,U)_" on "_$$FMTE^XLFDT($P(NODE,U,2)) Q
+16 SET NODE=$GET(^WV(790.4,IEN,1))
IF NODE'=U
SET METHOD("Spoke to "_$PIECE(NODE,U)_" on "_$$FMTE^XLFDT($PIECE(NODE,U,2)))=""
QUIT
+17 ;S TCNT=TCNT+1,TEXT(TCNT)=NAME_$S(DATE>0:" "_$$FMTE^XLFDT(DATE),1:"")
+18 SET METHOD(NAME_$SELECT(DATE>0:" "_$$FMTE^XLFDT(DATE),1:""))=""
End DoDot:2
QUIT
+19 ;S TCNT=TCNT+1,TEXT(TCNT)=NAME_$S(DATE>0:" "_$$FMTE^XLFDT(DATE),1:"")
+20 SET METHOD(NAME_$SELECT(DATE>0:" "_$$FMTE^XLFDT(DATE),1:""))=""
End DoDot:1
+21 SET TEMP=""
FOR
SET TEMP=$ORDER(METHOD(TEMP))
if TEMP=""
QUIT
Begin DoDot:1
+22 SET TCNT=TCNT+1
SET TEXT(TCNT)=TEMP
End DoDot:1
+23 IF TCNT=1
SET TCNT=TCNT+1
SET TEXT(TCNT)="None on file"
+24 QUIT
+25 ;
BRNEEDS(RESULT,BDT,EDT,TEST) ;
+1 NEW DATE,END,PAT,PROC
+2 SET PROC=$ORDER(^WV(790.51,"B",TEST,""))
if PROC'>0
QUIT
+3 SET DATE=$SELECT(BDT>0:BDT,1:0)
+4 SET END=$SELECT(EDT>0:EDT,1:DT)
+5 FOR
SET DATE=$ORDER(^WV(790,"BRNEEDS",PROC,DATE))
if DATE'>0!(DATE'<END)
QUIT
Begin DoDot:1
+6 SET PAT=""
FOR
SET PAT=$ORDER(^WV(790,"BRNEEDS",PROC,DATE,PAT))
if PAT'>0
QUIT
SET RESULT(PAT)=DATE
End DoDot:1
+7 QUIT
+8 ;
GETTEST(WVIEN,TEXT,DIAG) ;
+1 NEW Y
+2 KILL ^TMP("WV RPT",$JOB)
+3 DO EN^WVALERTR(+WVIEN,.DIAG)
+4 IF '$DATA(^TMP("WV RPT",$JOB))
SET TEXT(1)="No Imaging found in Radiology Package"
QUIT
+5 SET Y=0
FOR
SET Y=$ORDER(^TMP("WV RPT",$JOB,Y))
if Y'>0
QUIT
SET INC=INC+1
SET TEXT(INC)=$GET(^TMP("WV RPT",$JOB,Y,0))
+6 KILL ^TMP("WV RPT",$JOB)
+7 QUIT
+8 ;
SETOPEN(DA,VALUES) ;
+1 IF +VALUES(1)'>0
QUIT 0
+2 IF VALUES(2)=""
QUIT 0
+3 IF VALUES(3)=""
QUIT 0
+4 IF VALUES(4)'="o"
QUIT 0
+5 QUIT 1
+6 ;
KILLOPEN(DA,VALUES) ;
+1 IF +VALUES(1)'>0
QUIT 1
+2 IF VALUES(2)=""
QUIT 1
+3 IF VALUES(3)=""
QUIT 1
+4 IF VALUES(4)'="o"
QUIT 1
+5 QUIT 0
+6 ;
RETBIRAD(CODE,PDTE) ;
+1 NEW DTE,WVDATES
+2 IF PDTE=0
QUIT CODE
+3 ;I '$$INSTALDT^XPDUTL("WV*1.0*32",.WVDATES) Q CODE
+4 IF '$$INSTALDT^XPDUTL("RA*5.0*206",.WVDATES)
QUIT CODE
+5 IF CODE'="BI-RADS CATEGORY 0 Need Additional Imaging Evaluation"
QUIT CODE
+6 SET DTE=+$ORDER(WVDATES("A"),-1)
IF DTE=0
QUIT CODE
+7 IF PDTE<DTE
SET CODE="BI-RADS CATEGORY 0"
+8 QUIT CODE
+9 ;
