MAGDMEDL ;WOIFO/LB - Routine to look up entries in the Medicine files ; 06/06/2007 09:42
;;3.0;IMAGING;**51,54**;03-July-2009;;Build 1424
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
SELECT(ITEM,ARRAY) ;
;
N CNT,DIR,DIROUT,DIRUT,ENTRY
S CNT=+ARRAY
I 'CNT Q 0
S DIR(0)="NO^1:"_CNT,DIR("A")="Select a Medicine Procedure"
S DIR("T")=600 D ^DIR
I $D(DIRUT)!($D(DIROUT)) Q 0
S ENTRY=+Y
I '$D(ARRAY(ENTRY)) D G SELECT
. W !,"Please select an entry or use '^' to exit"
W !,"You have selected ",$P(ARRAY(ENTRY),"^"),"."
Q $P(ARRAY(ENTRY),"^",2)
;
LOOP(ARRAY,MAGPAT,SUB,CASEDT) ;
; MAGPAT = patient's dfn
; SUB = Medicine specialty
; CASEDT = case date
; array(0)= 1 or 0 ^ # entries found ^ message text
; array(#)= formatted out display without delimiters
; array(#,1) = internal stored values
; Variable MAGDIMG
S ARRAY(0)="0^^No entries found"
Q:'MAGPAT
Q:'$D(MAGMC)#10 ;Array should be available.
N BEG,CDT,CNT,DATA,DICOM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRC,PRCNM,SSN,THEDT,X1,X2,X
N IEN,II,IOUT,MAGMC,MEDFILE
Q:'$$FIND1^DIC(2,,"A",MAGPAT,"","")
S PATNME=$P(^DPT(MAGPAT,0),"^"),SSN=$P(^(0),"^",9)
S PATIENT=PATNME_" "_SSN
S:'CASEDT CASEDT=DT
S BEG=$$FMADD^XLFDT(CASEDT,-3),END=CASEDT+.9999,CNT=0,CDT=BEG-.001
F S CDT=$O(MAGMC(MAGPAT,SUB,CDT)) Q:'CDT!(CDT>END) D
. S EN=0 F S EN=$O(MAGMC(MAGPAT,SUB,CDT,EN)) Q:'EN D
. . S DATA=MAGMC(MAGPAT,SUB,CDT,EN)
. . S PRCNM=$P(DATA,"^",2),PRC=SUB
. . S THEDT=$P(DATA,"^"),IEN=$P(DATA,"^",5)
. . I $D(MAGMC(MAGPAT,SUB,CDT,EN,2005)) S (IOUT,II)=0 D
. . . F S II=$O(MAGMC(MAGPAT,SUB,CDT,EN,2005,II)) Q:'II!IOUT D
. . . . S IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II)
. . . . I '$D(^MAG(2005,IMAGEPTR)) S IMAGEPTR="" Q
. . . . I '$D(^MAG(2005,IMAGEPTR,"PACS")) S IMAGEPTR="",IOUT=1
. . S MEDFILE=$P(DATA,"^",4),MEDFILE=$P(MEDFILE,"MCAR(",2)
. . S DICOM="" D DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT)
. . I DICOM'="" D
. . . S DICOM=$P(DICOM,":",2)
. . . S CNT=CNT+1
. . . S ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT
. . . S ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$G(IMAGEPTR)_"^"_MEDFILE
I CNT S ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT
Q
;
DISPLAY(ARRAY) ;
; Call routine needs to pass array in the following sequence
; ARRAY(0)= 1 or 0 ^ #entries ^ message
; ARRAY(#)= Formatted output to be displayed.
; Will set the RES variable for selected entry.
I '$D(ARRAY(0)) Q 0
; If only one entry return the subscript variable.
I $P(ARRAY(0),"^",2)=1 Q 1
I $P(ARRAY(0),"^")'=1 Q 0
N ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES
S RES=0,MSG=$P(ARRAY(0),"^",3)
S IOF="#,$C(27,91,72,27,91,74,8,8,8,8)",IO=0,IOSL=24,POP=0
D HEAD
S (ENTRY,OUT)=0,ITEMS=$P(ARRAY(0),"^",2)
F S ENTRY=$O(ARRAY(ENTRY)) Q:'ENTRY!OUT D
. S OUTPUT=$G(ARRAY(ENTRY))
. D:$Y+3>IOSL HEAD D LINE
. D:$Y+3>IOSL ASKQ
I 'OUT D ASKQ S RES=ITEM
Q RES
;
HEAD ;
W:$Y+3>IOSL @IOF W !,MSG
Q
;
LINE ;
W !,ENTRY,".) "_OUTPUT
Q
;
ASKQ ;
N X,Y,DIR
S DIR(0)="L^1:"_$S('ENTRY:ITEMS,1:ENTRY)
S DIR("T")=600,DIR("A")="Select an entry: " D ^DIR
S ITEM=+Y
Q:$D(DIRUT)!($D(DIROUT))
Q:'ITEM
I '$D(ARRAY(ITEM)) W !,"Please select an entry or '^' to exit" G ASKQ
W !,"You have selected ",$P($G(ARRAY(ITEM)),"^")
S OUT=1
Q
;
ASKMORE() ;
N DIR,DATE,X,XX,Y
Q:'$D(MAGPAT)
Q:'$D(SUB)
S DIR(0)="Y",DIR("B")="NO"
S DIR("A")="Search further"
D ^DIR K DIR
I 'Y Q 0
W !,"Search will include 3 days prior to the day specified."
S DIR(0)="D^::EXP" D ^DIR
; Y2K compliance all calls to %DT must have either past or future date
I 'Y Q 0
S DATE=Y
D LOOP(.XX,MAGPAT,SUB,DATE)
I $D(XX(0)),$P(XX(0),"^")=0 D Q 0
. W "No entries found."
Q 1
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDMEDL 4747 printed Dec 13, 2024@02:00:46 Page 2
MAGDMEDL ;WOIFO/LB - Routine to look up entries in the Medicine files ; 06/06/2007 09:42
+1 ;;3.0;IMAGING;**51,54**;03-July-2009;;Build 1424
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ;
SELECT(ITEM,ARRAY) ;
+1 ;
+2 NEW CNT,DIR,DIROUT,DIRUT,ENTRY
+3 SET CNT=+ARRAY
+4 IF 'CNT
QUIT 0
+5 SET DIR(0)="NO^1:"_CNT
SET DIR("A")="Select a Medicine Procedure"
+6 SET DIR("T")=600
DO ^DIR
+7 IF $DATA(DIRUT)!($DATA(DIROUT))
QUIT 0
+8 SET ENTRY=+Y
+9 IF '$DATA(ARRAY(ENTRY))
Begin DoDot:1
+10 WRITE !,"Please select an entry or use '^' to exit"
End DoDot:1
GOTO SELECT
+11 WRITE !,"You have selected ",$PIECE(ARRAY(ENTRY),"^"),"."
+12 QUIT $PIECE(ARRAY(ENTRY),"^",2)
+13 ;
LOOP(ARRAY,MAGPAT,SUB,CASEDT) ;
+1 ; MAGPAT = patient's dfn
+2 ; SUB = Medicine specialty
+3 ; CASEDT = case date
+4 ; array(0)= 1 or 0 ^ # entries found ^ message text
+5 ; array(#)= formatted out display without delimiters
+6 ; array(#,1) = internal stored values
+7 ; Variable MAGDIMG
+8 SET ARRAY(0)="0^^No entries found"
+9 if 'MAGPAT
QUIT
+10 ;Array should be available.
if '$DATA(MAGMC)#10
QUIT
+11 NEW BEG,CDT,CNT,DATA,DICOM,EN,END,IMG,IMAGEPTR,MAGDIMG,PATIENT,PATNME,PRC,PRCNM,SSN,THEDT,X1,X2,X
+12 NEW IEN,II,IOUT,MAGMC,MEDFILE
+13 if '$$FIND1^DIC(2,,"A",MAGPAT,"","")
QUIT
+14 SET PATNME=$PIECE(^DPT(MAGPAT,0),"^")
SET SSN=$PIECE(^(0),"^",9)
+15 SET PATIENT=PATNME_" "_SSN
+16 if 'CASEDT
SET CASEDT=DT
+17 SET BEG=$$FMADD^XLFDT(CASEDT,-3)
SET END=CASEDT+.9999
SET CNT=0
SET CDT=BEG-.001
+18 FOR
SET CDT=$ORDER(MAGMC(MAGPAT,SUB,CDT))
if 'CDT!(CDT>END)
QUIT
Begin DoDot:1
+19 SET EN=0
FOR
SET EN=$ORDER(MAGMC(MAGPAT,SUB,CDT,EN))
if 'EN
QUIT
Begin DoDot:2
+20 SET DATA=MAGMC(MAGPAT,SUB,CDT,EN)
+21 SET PRCNM=$PIECE(DATA,"^",2)
SET PRC=SUB
+22 SET THEDT=$PIECE(DATA,"^")
SET IEN=$PIECE(DATA,"^",5)
+23 IF $DATA(MAGMC(MAGPAT,SUB,CDT,EN,2005))
SET (IOUT,II)=0
Begin DoDot:3
+24 FOR
SET II=$ORDER(MAGMC(MAGPAT,SUB,CDT,EN,2005,II))
if 'II!IOUT
QUIT
Begin DoDot:4
+25 SET IMAGEPTR=MAGMC(MAGPAT,SUB,CDT,EN,2005,II)
+26 IF '$DATA(^MAG(2005,IMAGEPTR))
SET IMAGEPTR=""
QUIT
+27 IF '$DATA(^MAG(2005,IMAGEPTR,"PACS"))
SET IMAGEPTR=""
SET IOUT=1
End DoDot:4
End DoDot:3
+28 SET MEDFILE=$PIECE(DATA,"^",4)
SET MEDFILE=$PIECE(MEDFILE,"MCAR(",2)
+29 SET DICOM=""
DO DICOMID^MAGDMEDI(.DICOM,MEDFILE,IEN,PRC,MAGPAT)
+30 IF DICOM'=""
Begin DoDot:3
+31 SET DICOM=$PIECE(DICOM,":",2)
+32 SET CNT=CNT+1
+33 SET ARRAY(CNT)=DICOM_" "_PRCNM_", "_THEDT_" "_PATIENT
+34 SET ARRAY(CNT,1)=DICOM_"^"_PATNME_"^"_SSN_"^"_EN_"^"_PRCNM_"^"_PRC_"^"_$GET(IMAGEPTR)_"^"_MEDFILE
End DoDot:3
End DoDot:2
End DoDot:1
+35 IF CNT
SET ARRAY(0)="1^"_CNT_"^Medicine file entries for "_PATIENT
+36 QUIT
+37 ;
DISPLAY(ARRAY) ;
+1 ; Call routine needs to pass array in the following sequence
+2 ; ARRAY(0)= 1 or 0 ^ #entries ^ message
+3 ; ARRAY(#)= Formatted output to be displayed.
+4 ; Will set the RES variable for selected entry.
+5 IF '$DATA(ARRAY(0))
QUIT 0
+6 ; If only one entry return the subscript variable.
+7 IF $PIECE(ARRAY(0),"^",2)=1
QUIT 1
+8 IF $PIECE(ARRAY(0),"^")'=1
QUIT 0
+9 NEW ENTRY,ITEM,ITEMS,MSG,OUT,OUTPUT,RES
+10 SET RES=0
SET MSG=$PIECE(ARRAY(0),"^",3)
+11 SET IOF="#,$C(27,91,72,27,91,74,8,8,8,8)"
SET IO=0
SET IOSL=24
SET POP=0
+12 DO HEAD
+13 SET (ENTRY,OUT)=0
SET ITEMS=$PIECE(ARRAY(0),"^",2)
+14 FOR
SET ENTRY=$ORDER(ARRAY(ENTRY))
if 'ENTRY!OUT
QUIT
Begin DoDot:1
+15 SET OUTPUT=$GET(ARRAY(ENTRY))
+16 if $Y+3>IOSL
DO HEAD
DO LINE
+17 if $Y+3>IOSL
DO ASKQ
End DoDot:1
+18 IF 'OUT
DO ASKQ
SET RES=ITEM
+19 QUIT RES
+20 ;
HEAD ;
+1 if $Y+3>IOSL
WRITE @IOF
WRITE !,MSG
+2 QUIT
+3 ;
LINE ;
+1 WRITE !,ENTRY,".) "_OUTPUT
+2 QUIT
+3 ;
ASKQ ;
+1 NEW X,Y,DIR
+2 SET DIR(0)="L^1:"_$SELECT('ENTRY:ITEMS,1:ENTRY)
+3 SET DIR("T")=600
SET DIR("A")="Select an entry: "
DO ^DIR
+4 SET ITEM=+Y
+5 if $DATA(DIRUT)!($DATA(DIROUT))
QUIT
+6 if 'ITEM
QUIT
+7 IF '$DATA(ARRAY(ITEM))
WRITE !,"Please select an entry or '^' to exit"
GOTO ASKQ
+8 WRITE !,"You have selected ",$PIECE($GET(ARRAY(ITEM)),"^")
+9 SET OUT=1
+10 QUIT
+11 ;
ASKMORE() ;
+1 NEW DIR,DATE,X,XX,Y
+2 if '$DATA(MAGPAT)
QUIT
+3 if '$DATA(SUB)
QUIT
+4 SET DIR(0)="Y"
SET DIR("B")="NO"
+5 SET DIR("A")="Search further"
+6 DO ^DIR
KILL DIR
+7 IF 'Y
QUIT 0
+8 WRITE !,"Search will include 3 days prior to the day specified."
+9 SET DIR(0)="D^::EXP"
DO ^DIR
+10 ; Y2K compliance all calls to %DT must have either past or future date
+11 IF 'Y
QUIT 0
+12 SET DATE=Y
+13 DO LOOP(.XX,MAGPAT,SUB,DATE)
+14 IF $DATA(XX(0))
IF $PIECE(XX(0),"^")=0
Begin DoDot:1
+15 WRITE "No entries found."
End DoDot:1
QUIT 0
+16 QUIT 1
+17 ;
