- MAGJLS4 ;WIRMFO/JHC - VistARad RPCs--History List ; 10/17/2022
- ;;3.0;IMAGING;**18,76,101,341**;Dec 21, 2022;Build 28
- ;;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. |
- ;; +---------------------------------------------------------------+
- ;;
- ;; ISI IMAGING;**99**
- Q
- ERR N ERR S ERR=$$EC^%ZOSV S ^TMP($J,"RET",0)="0^4~"_ERR
- S MAGGRY=$NA(^TMP($J,"RET"))
- D @^%ZOSF("ERRTN")
- Q:$Q 1 Q
- ;
- ; Subroutines for Vistarad History List functions
- ; Entry Points:
- ; HIST -- All History List rpcs go here
- ;
- HIST(MAGGRY,PARAMS,DATA) ; History List RPC: MAGJ HISTORYLIST
- ; PARAMS--TXID ^ TXDUZ ^ TXDIV
- ; TXID: Required; designates action to take; see below
- ; TXDUZ: Optional; if supplied, get data for another user (Read Only)
- ; TXDIV: Optional; if supplied, get data for another division (Read Only)
- ; Note: for now, TXDIV is forced to the Logon Division
- ; DATA--(optional) array of input data; depends on TXID; see subroutines by TXID
- ;
- N $ETRAP,$ESTACK S $ETRAP="D ERR^MAGJLS4"
- N TXID,TXDUZ,TXDIV,UPDATEOK,DIQUIET,REPLY
- K ^TMP($J,"RET")
- S TXID=+PARAMS,TXDUZ=+$P(PARAMS,U,2),TXDIV=+$P(PARAMS,U,3)
- I 'TXDUZ S TXDUZ=DUZ
- S UPDATEOK=TXDUZ=DUZ
- S TXDIV=DUZ(2) ; Force to Logon Division for now
- S REPLY="0^1~Performing History List operation."
- I 'TXID!'("1,2,3"[TXID) S REPLY="0^4~Invalid History List operation requested." G HISTZ
- I '$D(DATA)&(TXID=1!TXID=3) S REPLY="0^4~No data supplied for History List update/delete." G HISTZ
- I 'UPDATEOK&("1,3"[TXID) S REPLY="0^4~The current History List may not be updated by the current user." G HISTZ
- S DIQUIET=1 D DT^DICRW
- I TXID=1 D HISTADD(.DATA,TXDUZ,TXDIV) G HISTZ
- I TXID=2 D HISTUPD(TXDUZ,TXDIV) D HISTGET(TXDUZ,TXDIV) G HISTZ
- I TXID=3 D HISTDEL(.DATA,TXDUZ,TXDIV) G HISTZ
- ; I TXID=4 D HISTUPD(TXDUZ,TXDIV) G HISTZ ; for now, do this function with txid 2
- HISTZ ;
- I 'REPLY S MAGGRY=$NA(^TMP($J,"RET")),@MAGGRY@(0)=REPLY
- E ; maggry otherwise has been set by called subroutine
- Q
- ;
- HISTADD(DATA,TXDUZ,TXDIV) ; add records
- N IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT,TS
- S IDATA="",CT=0,NOGO=0
- F ILOOP=0:1 S IDATA=$O(DATA(IDATA)) Q:IDATA="" D
- . S EXID=$P(DATA(IDATA),"|"),HISDAT=$P(DATA(IDATA),"|",2)
- . F I=1:1:4 I '+$P(EXID,U,I) S NOGO=1 Q
- . I NOGO Q
- . L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2
- . E Q
- . S X=$G(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0)),HISTIEN=+$P(X,U)+1,$P(^(0),U)=HISTIEN
- . L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)
- . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD",HISTIEN)="|"_EXID_"|"_HISTIEN_U_HISDAT_"|"
- . S CT=CT+1
- I 'CT S REPLY="0^3~"_$S(ILOOP:"Unable to add records",1:"No records to add")_" to History List." Q
- S MAGRACNT=0 D ACTIVE^MAGJLS2(.MAGGRY,9996)
- S X=@MAGGRY@(0),X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV),@MAGGRY@(0)=X
- S TS="" F I=2,0 S TS=TS_$S(TS="":"",1:U)_$$HTFM^XLFDT($H+I,0)
- S ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile"
- S REPLY=1
- Q
- ;
- HISTTL(TXDUZ,TXDIV) ; Build list title string
- N LSTTL
- S LSTTL="HISTORY LIST for "_$$USERINF^MAGJUTL3(TXDUZ,.01)_" at "_"Station #"_$$STATN^MAGJEX1(TXDIV)
- S LSTTL=LSTTL_"|"_TXDUZ ; provide report's DUZ to client
- Q LSTTL
- ;
- HISTGET(TXDUZ,TXDIV) ; Get full History List for input user for division txdiv
- N MAGLST,LSTTL,LSTID,MAGLST
- S TXDUZ=$G(TXDUZ,DUZ)
- S TXDIV=$G(TXDIV,DUZ(2))
- N DATA01 S DATA01=9996 ; ISI
- D PARAMS^MAGJLS2B(9996)
- I 'LSTID S REPLY="0^4~Problem with History List Compile." Q
- S LSTTL=$$HISTTL(TXDUZ,DUZ(2))
- S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0))
- I 'X S REPLY="0^1~No exams found for: "_LSTTL Q
- S MAGLST=$NA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV))
- D LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST)
- S REPLY=1
- Q
- ;
- HISTDEL(DATA,TXDUZ,TXDIV) ; delete records
- N IDATA,CT,HISTIEN,ALLDONE,LAST
- S IDATA="",CT=0,ALLDONE=0
- L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2
- E S REPLY="0^2~Unable to access HISTORY File for deleting records; try again later." Q
- S MAGGRY=$NA(^TMP($J,"RET"))
- F S IDATA=$O(DATA(IDATA)) Q:IDATA=""!ALLDONE D
- . S HISTIEN=$P(DATA(IDATA),U)
- . I HISTIEN,$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN Q
- . E I HISTIEN="ALL" S HISTIEN=0 D S ALLDONE=1
- . . F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN K ^(HISTIEN) S CT=CT+1,@MAGGRY@(CT)=HISTIEN
- I '$D(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD")) S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X
- L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)
- I 'CT S REPLY="0^3~No HISTORY List records found to delete."
- E S REPLY=CT_"^1~"_CT_" HISTORY List records deleted."
- S @MAGGRY@(0)=REPLY
- S REPLY=1
- Q
- ;
- HISTUPD(TXDUZ,TXDIV) ; Update selected fields in History List
- N LSTTL,CT,NOHIT,RAST,STATUS,REMOTE,RIST1,RIST2,RIST,RISTISME
- N EXID,HISTIEN,RARPT,RADFN,RADTI,RACNI,XX1,XX2,T,X,DELETED,HDATE
- S CT=0,NOHIT=0
- S TXDUZ=$G(TXDUZ,DUZ)
- S TXDIV=$G(TXDIV,DUZ(2))
- S LSTTL=$$HISTTL(TXDUZ,DUZ(2))
- S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0))
- I 'X S REPLY="0^1~No exams found for: "_LSTTL Q
- L +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2
- E S REPLY="0^2~Unable to access HISTORY File for updating records; try again later." Q
- S HISTIEN=0
- F S HISTIEN=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)) Q:'HISTIEN S XX1=$G(^(HISTIEN,1)),XX2=$G(^(2)) D
- . S EXID=$P(XX2,"|",2),RARPT=+$P(EXID,U,4),RADFN=+$P(EXID,U),RADTI=+$P(EXID,U,2),RACNI=+$P(EXID,U,3)
- . ; <*> Below is for phase 1 Alpha, til have final user setting for this <*> to be removed
- . ; Age limit parameter to be passed in with txid 2 rpc call; setting is on client <*>
- . S HDATE=$P(XX2,U,13) D Q:DELETED
- . . S DELETED=0,HDATE=$P(HDATE,"@")
- . . S X=HDATE,%DT="" D ^%DT K %DT
- . . I $$FMTH^XLFDT(Y,1)<($H-3) K ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN) S DELETED=1 Q
- . ; <*> End of temp change
- . I RARPT,RADFN,RADTI,RACNI
- . E S NOHIT=NOHIT+1 Q
- . D IMGINFO^MAGJUTL2(RARPT,.X) S REMOTE=$P(X,U,4)
- . S X=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- . I X="" Q ; rad exam deleted
- . S RAST=$P(X,U,3),RIST1=$P(X,U,12),RIST2=$P(X,U,15)
- . S STATUS=$S(RAST:$P(^RA(72,RAST,0),U),1:"")
- . S (RIST,RISTISME)=""
- . I RIST1!RIST2 S X=$$RIST^MAGJUTL1(RIST1,RIST2),RIST=$P(X,U),RISTISME=$P(X,U,2)
- . S RISTISME=$$RISTISME^MAGJLS2B(RISTISME)
- . S $P(XX1,U,16)=RAST,$P(XX1,U,8)=STATUS,$P(XX1,U,12)=REMOTE
- . S T=$P(XX2,"|"),$P(T,U,3)=RIST,$P(T,U,7)=RISTISME,$P(XX2,"|")=T
- . S ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN,1)=XX1,^(2)=XX2
- . S CT=CT+1
- S X=$O(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1),^(0)=X_U_X ; <*> for phase 1 alpha only?
- L -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)
- S REPLY="0^1~HISTORY File records updated." Q
- Q
- ;
- END Q ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGJLS4 7615 printed Feb 18, 2025@23:33:17 Page 2
- MAGJLS4 ;WIRMFO/JHC - VistARad RPCs--History List ; 10/17/2022
- +1 ;;3.0;IMAGING;**18,76,101,341**;Dec 21, 2022;Build 28
- +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 ;; | |
- +11 ;; | The Food and Drug Administration classifies this software as |
- +12 ;; | a medical device. As such, it may not be changed in any way. |
- +13 ;; | Modifications to this software may result in an adulterated |
- +14 ;; | medical device under 21CFR820, the use of which is considered |
- +15 ;; | to be a violation of US Federal Statutes. |
- +16 ;; +---------------------------------------------------------------+
- +17 ;;
- +18 ;; ISI IMAGING;**99**
- +19 QUIT
- ERR NEW ERR
- SET ERR=$$EC^%ZOSV
- SET ^TMP($JOB,"RET",0)="0^4~"_ERR
- +1 SET MAGGRY=$NAME(^TMP($JOB,"RET"))
- +2 DO @^%ZOSF("ERRTN")
- +3 if $QUIT
- QUIT 1
- QUIT
- +4 ;
- +5 ; Subroutines for Vistarad History List functions
- +6 ; Entry Points:
- +7 ; HIST -- All History List rpcs go here
- +8 ;
- HIST(MAGGRY,PARAMS,DATA) ; History List RPC: MAGJ HISTORYLIST
- +1 ; PARAMS--TXID ^ TXDUZ ^ TXDIV
- +2 ; TXID: Required; designates action to take; see below
- +3 ; TXDUZ: Optional; if supplied, get data for another user (Read Only)
- +4 ; TXDIV: Optional; if supplied, get data for another division (Read Only)
- +5 ; Note: for now, TXDIV is forced to the Logon Division
- +6 ; DATA--(optional) array of input data; depends on TXID; see subroutines by TXID
- +7 ;
- +8 NEW $ETRAP,$ESTACK
- SET $ETRAP="D ERR^MAGJLS4"
- +9 NEW TXID,TXDUZ,TXDIV,UPDATEOK,DIQUIET,REPLY
- +10 KILL ^TMP($JOB,"RET")
- +11 SET TXID=+PARAMS
- SET TXDUZ=+$PIECE(PARAMS,U,2)
- SET TXDIV=+$PIECE(PARAMS,U,3)
- +12 IF 'TXDUZ
- SET TXDUZ=DUZ
- +13 SET UPDATEOK=TXDUZ=DUZ
- +14 ; Force to Logon Division for now
- SET TXDIV=DUZ(2)
- +15 SET REPLY="0^1~Performing History List operation."
- +16 IF 'TXID!'("1,2,3"[TXID)
- SET REPLY="0^4~Invalid History List operation requested."
- GOTO HISTZ
- +17 IF '$DATA(DATA)&(TXID=1!TXID=3)
- SET REPLY="0^4~No data supplied for History List update/delete."
- GOTO HISTZ
- +18 IF 'UPDATEOK&("1,3"[TXID)
- SET REPLY="0^4~The current History List may not be updated by the current user."
- GOTO HISTZ
- +19 SET DIQUIET=1
- DO DT^DICRW
- +20 IF TXID=1
- DO HISTADD(.DATA,TXDUZ,TXDIV)
- GOTO HISTZ
- +21 IF TXID=2
- DO HISTUPD(TXDUZ,TXDIV)
- DO HISTGET(TXDUZ,TXDIV)
- GOTO HISTZ
- +22 IF TXID=3
- DO HISTDEL(.DATA,TXDUZ,TXDIV)
- GOTO HISTZ
- +23 ; I TXID=4 D HISTUPD(TXDUZ,TXDIV) G HISTZ ; for now, do this function with txid 2
- HISTZ ;
- +1 IF 'REPLY
- SET MAGGRY=$NAME(^TMP($JOB,"RET"))
- SET @MAGGRY@(0)=REPLY
- +2 ; maggry otherwise has been set by called subroutine
- IF '$TEST
- +3 QUIT
- +4 ;
- HISTADD(DATA,TXDUZ,TXDIV) ; add records
- +1 NEW IDATA,ILOOP,CT,NOGO,EXID,HISDAT,HISTIEN,MAGRACNT,TS
- +2 SET IDATA=""
- SET CT=0
- SET NOGO=0
- +3 FOR ILOOP=0:1
- SET IDATA=$ORDER(DATA(IDATA))
- if IDATA=""
- QUIT
- Begin DoDot:1
- +4 SET EXID=$PIECE(DATA(IDATA),"|")
- SET HISDAT=$PIECE(DATA(IDATA),"|",2)
- +5 FOR I=1:1:4
- IF '+$PIECE(EXID,U,I)
- SET NOGO=1
- QUIT
- +6 IF NOGO
- QUIT
- +7 LOCK +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2
- +8 IF '$TEST
- QUIT
- +9 SET X=$GET(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0))
- SET HISTIEN=+$PIECE(X,U)+1
- SET $PIECE(^(0),U)=HISTIEN
- +10 LOCK -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)
- +11 SET ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD",HISTIEN)="|"_EXID_"|"_HISTIEN_U_HISDAT_"|"
- +12 SET CT=CT+1
- End DoDot:1
- +13 IF 'CT
- SET REPLY="0^3~"_$SELECT(ILOOP:"Unable to add records",1:"No records to add")_" to History List."
- QUIT
- +14 SET MAGRACNT=0
- DO ACTIVE^MAGJLS2(.MAGGRY,9996)
- +15 SET X=@MAGGRY@(0)
- SET X=+X_U_"1~"_$$HISTTL(TXDUZ,TXDIV)
- SET @MAGGRY@(0)=X
- +16 SET TS=""
- FOR I=2,0
- SET TS=TS_$SELECT(TS="":"",1:U)_$$HTFM^XLFDT($HOROLOG+I,0)
- +17 SET ^XTMP("MAGJ2",0)=TS_U_"VistaRad List Compile"
- +18 SET REPLY=1
- +19 QUIT
- +20 ;
- HISTTL(TXDUZ,TXDIV) ; Build list title string
- +1 NEW LSTTL
- +2 SET LSTTL="HISTORY LIST for "_$$USERINF^MAGJUTL3(TXDUZ,.01)_" at "_"Station #"_$$STATN^MAGJEX1(TXDIV)
- +3 ; provide report's DUZ to client
- SET LSTTL=LSTTL_"|"_TXDUZ
- +4 QUIT LSTTL
- +5 ;
- HISTGET(TXDUZ,TXDIV) ; Get full History List for input user for division txdiv
- +1 NEW MAGLST,LSTTL,LSTID,MAGLST
- +2 SET TXDUZ=$GET(TXDUZ,DUZ)
- +3 SET TXDIV=$GET(TXDIV,DUZ(2))
- +4 ; ISI
- NEW DATA01
- SET DATA01=9996
- +5 DO PARAMS^MAGJLS2B(9996)
- +6 IF 'LSTID
- SET REPLY="0^4~Problem with History List Compile."
- QUIT
- +7 SET LSTTL=$$HISTTL(TXDUZ,DUZ(2))
- +8 SET X=$ORDER(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0))
- +9 IF 'X
- SET REPLY="0^1~No exams found for: "_LSTTL
- QUIT
- +10 SET MAGLST=$NAME(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV))
- +11 DO LSTOUT^MAGJLS2B(.MAGGRY,LSTID,MAGLST)
- +12 SET REPLY=1
- +13 QUIT
- +14 ;
- HISTDEL(DATA,TXDUZ,TXDIV) ; delete records
- +1 NEW IDATA,CT,HISTIEN,ALLDONE,LAST
- +2 SET IDATA=""
- SET CT=0
- SET ALLDONE=0
- +3 LOCK +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2
- +4 IF '$TEST
- SET REPLY="0^2~Unable to access HISTORY File for deleting records; try again later."
- QUIT
- +5 SET MAGGRY=$NAME(^TMP($JOB,"RET"))
- +6 FOR
- SET IDATA=$ORDER(DATA(IDATA))
- if IDATA=""!ALLDONE
- QUIT
- Begin DoDot:1
- +7 SET HISTIEN=$PIECE(DATA(IDATA),U)
- +8 IF HISTIEN
- IF $DATA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN))
- KILL ^(HISTIEN)
- SET CT=CT+1
- SET @MAGGRY@(CT)=HISTIEN
- QUIT
- +9 IF '$TEST
- IF HISTIEN="ALL"
- SET HISTIEN=0
- Begin DoDot:2
- +10 FOR
- SET HISTIEN=$ORDER(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN))
- if 'HISTIEN
- QUIT
- KILL ^(HISTIEN)
- SET CT=CT+1
- SET @MAGGRY@(CT)=HISTIEN
- End DoDot:2
- SET ALLDONE=1
- End DoDot:1
- +11 IF '$DATA(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0,"ADD"))
- SET X=$ORDER(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1)
- SET ^(0)=X_U_X
- +12 LOCK -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)
- +13 IF 'CT
- SET REPLY="0^3~No HISTORY List records found to delete."
- +14 IF '$TEST
- SET REPLY=CT_"^1~"_CT_" HISTORY List records deleted."
- +15 SET @MAGGRY@(0)=REPLY
- +16 SET REPLY=1
- +17 QUIT
- +18 ;
- HISTUPD(TXDUZ,TXDIV) ; Update selected fields in History List
- +1 NEW LSTTL,CT,NOHIT,RAST,STATUS,REMOTE,RIST1,RIST2,RIST,RISTISME
- +2 NEW EXID,HISTIEN,RARPT,RADFN,RADTI,RACNI,XX1,XX2,T,X,DELETED,HDATE
- +3 SET CT=0
- SET NOHIT=0
- +4 SET TXDUZ=$GET(TXDUZ,DUZ)
- +5 SET TXDIV=$GET(TXDIV,DUZ(2))
- +6 SET LSTTL=$$HISTTL(TXDUZ,DUZ(2))
- +7 SET X=$ORDER(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,0))
- +8 IF 'X
- SET REPLY="0^1~No exams found for: "_LSTTL
- QUIT
- +9 LOCK +^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV):2
- +10 IF '$TEST
- SET REPLY="0^2~Unable to access HISTORY File for updating records; try again later."
- QUIT
- +11 SET HISTIEN=0
- +12 FOR
- SET HISTIEN=$ORDER(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN))
- if 'HISTIEN
- QUIT
- SET XX1=$GET(^(HISTIEN,1))
- SET XX2=$GET(^(2))
- Begin DoDot:1
- +13 SET EXID=$PIECE(XX2,"|",2)
- SET RARPT=+$PIECE(EXID,U,4)
- SET RADFN=+$PIECE(EXID,U)
- SET RADTI=+$PIECE(EXID,U,2)
- SET RACNI=+$PIECE(EXID,U,3)
- +14 ; <*> Below is for phase 1 Alpha, til have final user setting for this <*> to be removed
- +15 ; Age limit parameter to be passed in with txid 2 rpc call; setting is on client <*>
- +16 SET HDATE=$PIECE(XX2,U,13)
- Begin DoDot:2
- +17 SET DELETED=0
- SET HDATE=$PIECE(HDATE,"@")
- +18 SET X=HDATE
- SET %DT=""
- DO ^%DT
- KILL %DT
- +19 IF $$FMTH^XLFDT(Y,1)<($HOROLOG-3)
- KILL ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN)
- SET DELETED=1
- QUIT
- End DoDot:2
- if DELETED
- QUIT
- +20 ; <*> End of temp change
- +21 IF RARPT
- IF RADFN
- IF RADTI
- IF RACNI
- +22 IF '$TEST
- SET NOHIT=NOHIT+1
- QUIT
- +23 DO IMGINFO^MAGJUTL2(RARPT,.X)
- SET REMOTE=$PIECE(X,U,4)
- +24 SET X=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
- +25 ; rad exam deleted
- IF X=""
- QUIT
- +26 SET RAST=$PIECE(X,U,3)
- SET RIST1=$PIECE(X,U,12)
- SET RIST2=$PIECE(X,U,15)
- +27 SET STATUS=$SELECT(RAST:$PIECE(^RA(72,RAST,0),U),1:"")
- +28 SET (RIST,RISTISME)=""
- +29 IF RIST1!RIST2
- SET X=$$RIST^MAGJUTL1(RIST1,RIST2)
- SET RIST=$PIECE(X,U)
- SET RISTISME=$PIECE(X,U,2)
- +30 SET RISTISME=$$RISTISME^MAGJLS2B(RISTISME)
- +31 SET $PIECE(XX1,U,16)=RAST
- SET $PIECE(XX1,U,8)=STATUS
- SET $PIECE(XX1,U,12)=REMOTE
- +32 SET T=$PIECE(XX2,"|")
- SET $PIECE(T,U,3)=RIST
- SET $PIECE(T,U,7)=RISTISME
- SET $PIECE(XX2,"|")=T
- +33 SET ^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,HISTIEN,1)=XX1
- SET ^(2)=XX2
- +34 SET CT=CT+1
- End DoDot:1
- +35 ; <*> for phase 1 alpha only?
- SET X=$ORDER(^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV,""),-1)
- SET ^(0)=X_U_X
- +36 LOCK -^XTMP("MAGJ2","HISTORY",TXDUZ,TXDIV)
- +37 SET REPLY="0^1~HISTORY File records updated."
- QUIT
- +38 QUIT
- +39 ;
- END ;
- QUIT