MAGDFCNV ;WOIFO/PMK - Read HL7 and generate DICOM ; Jan 13, 2026@11:26:58
;;3.0;IMAGING;**11,51,141,138,231,333**;Mar 19, 2002;Build 2
;; Per VA Directive 6402, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | |
;; | 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. |
;; +---------------------------------------------------------------+
;;
;
; Supported IA #2171 reference $$STA^XUAF4 function call
; Supported IA #2541 reference $$KSP^XUPARAM function call
; Supported IA #2051 reference $$FIND1^DIC function call
; Supported IA #2056 reference $$GET1^DIQ function call
; Controlled IA #4897 to read BUILD file (#9.6)
;
CONSOLID() ; check if this is a consolidated site or not
; return 0 = non-consolidated (normal) site
; return 1 = consolidated site
;
; code for the main VistA HIS
Q $GET(^MAG(2006.1,"CONSOLIDATED"))="YES"
;
ACQDEV(MFGR,MODEL,SITE) ; get pointer to the Acquisition Device file
N ACQDEV ;--- name of acquisition device
N ACQDEVP ;-- pointer to acquisition device file (#2006.04)
;
S ACQDEV=$$UP^MAGDFCNV(MFGR_" ("_MODEL_")")
S ACQDEVP=$O(^MAG(2006.04,"B",ACQDEV,""))
I 'ACQDEVP D ; create the entry
. L +^MAG(2006.04,0):1E9 ; serialize name generation code
. I '$D(^MAG(2006.04,0)) S ^(0)="ACQUISITION DEVICE^2006.04^^"
. S ACQDEVP=$P(^MAG(2006.04,0),"^",3)+1
. S ^MAG(2006.04,ACQDEVP,0)=ACQDEV_"^"_SITE_"^" ; 3rd piece is null
. S ^MAG(2006.04,"B",ACQDEV,ACQDEVP)=""
. S $P(^MAG(2006.04,0),"^",3)=ACQDEVP
. S $P(^MAG(2006.04,0),"^",4)=ACQDEVP
. L -^MAG(2006.04,0) ; clear the serial name generation code
Q ACQDEVP
;
EQUIVGRP(P1,P2) ; see if two SOP Class pointers are in equivalent groups
N G1,G2
Q:'$G(P1) 0
Q:'$G(P2) 0
S G1=$P($G(^MAG(2006.532,P1,0)),"^",3) S:G1="" G1=P1
S G2=$P($G(^MAG(2006.532,P2,0)),"^",3) S:G2="" G2=P2
Q G1=G2
;
UP(X) ; special UPPER CASE function -- removes redundant blanks as well
F Q:X'[" " S $E(X,$F(X," ")-1)="" ; remove redundant blank
I $E(X)=" " S $E(X)="" ; remove leading blank
I $E(X,$L(X))=" " S $E(X,$L(X))="" ; remove trailing blank
Q $TR(X,"abcdefghijklmnopqrstuvwxyz^|","ABCDEFGHIJKLMNOPQRSTUVWXYZ~~")
;
STATNUMB() ; return numeric 3-digit station number for the VA
N STATNUMB
S STATNUMB=$$STA^XUAF4($$KSP^XUPARAM("INST")) ; station number
; station number is 3 digits, exclusive of any modifiers or full station number for IHS
Q $S($$ISIHS^MAGSPID():STATNUMB,1:$E(STATNUMB,1,3))
;
DIVISION() ; return the user's hospital division - P333 PMK 01/13/2026
N DIVISION
S DIVISION=$G(DUZ(2),0) ; user's logon division
I 'DIVISION D
. S DIVISION="-1,User's Division is not defined"
. Q
Q DIVISION
;
GMRCACN(GMRCIEN) ; return a site-specific accession number for clinical specialties
; GMRCIEN is the CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
N A ; return DILIST from FIND^DIC
N ACNUMB ; accession number for a consult/procedure request
N EXAMDATE ; date of exam
N P162DATE ; installation date for MAG*3.0*162, when site-specific accession numbers started
; shouldn't use FIND1^DIC because it fails if the patch was installed multiple times
D FIND^DIC(9.7,"","17I;@","B","MAG*3.0*162","","","","","A") ; P333 PMK 12/15/2022
S P162DATE=$G(A("DILIST","ID",1,17)) ; install complete date & time
S EXAMDATE=$$GET1^DIQ(123,GMRCIEN,.01,"I")
I EXAMDATE<P162DATE D ; legacy accession number format
. ; Format: GMRC-<gmrcien>, where <gmrcien> is the internal entry number of the request
. S ACNUMB="GMRC-"_GMRCIEN
. Q
E D ; site-specific accession number format
. ; Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
. ; is the internal entry number of the request, up to 8 digits (100 million)
. S ACNUMB=$$STATNUMB()_"-GMR-"_GMRCIEN
. Q
Q ACNUMB
;
GMRCIEN(ACNUMB) ; return the GMRC IEN, given a consult/procedure accession number
; ACNUMB is the accession number for a consult/procedure request
; OLD Format: GMRC-<gmrcien>, where <gmrcien>is the internal entry number of the request
; New Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
; is the internal entry number of the request, up to 8 digits (100 million)
N GMRCIEN ; CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
I ACNUMB?1"GMRC-"1N.N S GMRCIEN=$P(ACNUMB,"-",2) ; return the second piece
E I ACNUMB?1N.N1"-GMR-"1N.N S GMRCIEN=$P(ACNUMB,"-",3) ; return the third piece
E S GMRCIEN="" ; invalid consult request tracking accession number format
Q GMRCIEN
;
HOSTNAME() ;
Q $P(##class(%SYS.System).GetNodeName(),".",1)
;
CHECKSUM ; interactive routine checksums - P333 PMK 06/06/2022
N DEFAULT,DONE,HELP,PROMPT,ROUTINE,X
;
U $P:132 ; switch to 132 character mode
S DEFAULT=""
S PROMPT="Checksums by Routine name or Patch number?"
S HELP(1)="Enter ""R"" to output the checksums for a set of named routines."
S HELP(2)="or ""P"" to output the checksums for all the routines in a patch."
S HELP(3)=""
S HELP(4)="Enter caret (""^"") to exit."
;
S DONE=0 F D Q:DONE
. K ^TMP("MAG",$J,"ROUTINES")
. I $$RP(PROMPT,DEFAULT,.X,.HELP)<0 S DONE=-1 Q
. I X="PATCH" D
. . D PATCH
. . S DEFAULT="P"
. . Q
. E D
. . D ROUTINE
. . S DEFAULT="R"
. . Q
. ;
. W ! D CHECKSUMS
. K ^TMP("MAG",$J,"ROUTINES")
. Q
U $P:IOM ; switch back to regular character mode
Q
;
ROUTINE ; get a list of routines
N DONE,LINE1,LINE2,R,SELECT,STATUS,STOP,X
K ^TMP("MAG",$J,"ROUTINES")
S DONE=0
F D Q:DONE
. W !,"Routine(s): "
. R X:DTIME
. I X="" S DONE=1 Q
. I X="^" S DONE=-1 Q
. I X?1"'".E S X=$E(X,2,999),SELECT=0 ; unselect the routine(s)
. E S SELECT=1 ; select the routine(s)
. I X?1"^".E S X=$E(X,2,999) ; strip off leading ^ in routine name
. I X?.E1"*" D
. . S (R,X)=$P(X,"*")
. . S STATUS=$$SAVERTN(R,SELECT)
. . S STOP=X_"ZZZ" F S R=$O(^ROUTINE(R)) Q:R="" Q:R]STOP D
. . . S STATUS=$$SAVERTN(R,SELECT)
. . . Q
. . Q
. E I $$SAVERTN(X,SELECT) ; set $T
. E W " -- not on file"
. Q
Q
;
SAVERTN(R,SELECT) ; save the routine info
N EXISTS,LINE1,LINE2
I $D(^ROUTINE(R)) D
. I SELECT D ; select the routine
. . S LINE1=$G(^ROUTINE(R,0,1)),LINE2=$G(^(2))
. . S ^TMP("MAG",$J,"ROUTINES",R)=$P(LINE1,";",3)_"^"_$P(LINE2,";",5)
. . Q
. E D ; unselect the routine
. . K ^TMP("MAG",$J,"ROUTINES",R)
. . Q
. S EXISTS=1
. Q
E S EXISTS=0
Q EXISTS
;
PATCH ; get a patch number
N A,B,DONE,IEN,LINE1,LINE2,PLIST,PATCH,R,S,X
S DONE=0
F D Q:DONE
. W !!,"Patch number: "
. R X:DTIME
. I "^"[X S DONE=1 Q
. I (X'?1N.N),(X'?1A.A1"*".1N.N.".".N1"*"1N.N) W " ???" S X="?"
. I "?"[X D Q
. . W !!,"Enter the full patch number or just the last digits for MAG*3.0*nnn"
. . Q
. I X?1N.N S PATCH="MAG*3.0*"_X
. E D
. . S PATCH=$$UP(X)
. . I $P(PATCH,"*",2)?1N.N S $P(PATCH,"*",2)=$P(PATCH,"*",2)_".0"
. . Q
. S IEN=$$FIND1^DIC(9.6,"","BX",PATCH)
. I IEN=0 W " ??? No ",PATCH," patch" Q
. D GETS^DIQ(9.67,"9.8,"_IEN_",","10*","N","A","B")
. S S="" F S S=$O(A(9.68,S)) Q:S="" D
. . S R=$G(A(9.68,S,.01)) Q:R=""
. . S LINE1=$G(^ROUTINE(R,0,1)),LINE2=$G(^(2))
. . S PLIST=$P(LINE2,";",5)
. . S ^TMP("MAG",$J,"ROUTINES",R)=$P(LINE1,";",3)_"^"_PLIST ; last edit date/time
. . Q
. S DONE=1
. Q
Q
;
CHECKSUMS ; output the checksums
N R
S R="" F S R=$O(^TMP("MAG",$J,"ROUTINES",R)) Q:R="" D
. W !,R,?10,$J($$CHK2(R),10)
. W ?23,$P($G(^TMP("MAG",$J,"ROUTINES",R)),"^",1) ; patch list
. W ?46,$P($G(^TMP("MAG",$J,"ROUTINES",R)),"^",2) ; last edit date/time
. Q
Q
;
NOQUOTES(X) ; "Copy as path" has leading and trailing quotes - remove them
I $E(X)="""",$E(X,$L(X))="""" S X=$E(X,2,$L(X)-1) ; P333 PMK 04/23/2025
Q X
;
RP(PROMPT,DEFAULT,CHOICE,HELP) ; generic question driver
N I,OK,X
S OK=0 F D Q:OK
. W !!,PROMPT," " I $L($G(DEFAULT)) W DEFAULT,"// "
. R X:DTIME E S X="^"
. I X="",$L($G(DEFAULT)) S X=DEFAULT W X
. I X="",'$L($G(DEFAULT)) S X="*" ; fails tests
. I X["^" S CHOICE="^",OK=-1 Q
. I "Pp"[$E(X) S CHOICE="PATCH",OK=1 Q
. I "Rr"[$E(X) S CHOICE="ROUTINE",OK=1 Q
. I X["?",$D(HELP) D
. . W !
. . F I=1:1 Q:'$D(HELP(I)) W !,HELP(I)
. . Q
. E W " ???",!,"Please enter ""R"" for routines or ""P"" for a patch"
. Q
Q OK
;
CHK2(R) ; checksum algorithm for a routine
N K,X,Y
S Y=0
F K=1:1 S X=$T(+K^@R) Q:X="" S:K'=2 Y=Y+$$C2(X,K)
Q Y
;
C2(X,K) ; checksum algorithm for a line
N F,I,Y
S Y=0
S F=$F(X," "),F=$S($E(X,F)'=";":$L(X),$E(X,F+1)=";":$L(X),1:F-2)
F I=1:1:F S Y=$A(X,I)*(I+K)+Y
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDFCNV 9231 printed Mar 25, 2026@15:24:27 Page 2
MAGDFCNV ;WOIFO/PMK - Read HL7 and generate DICOM ; Jan 13, 2026@11:26:58
+1 ;;3.0;IMAGING;**11,51,141,138,231,333**;Mar 19, 2002;Build 2
+2 ;; Per VA Directive 6402, 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 ;; | |
+7 ;; | The Food and Drug Administration classifies this software as |
+8 ;; | a medical device. As such, it may not be changed in any way. |
+9 ;; | Modifications to this software may result in an adulterated |
+10 ;; | medical device under 21CFR820, the use of which is considered |
+11 ;; | to be a violation of US Federal Statutes. |
+12 ;; +---------------------------------------------------------------+
+13 ;;
+14 ;
+15 ; Supported IA #2171 reference $$STA^XUAF4 function call
+16 ; Supported IA #2541 reference $$KSP^XUPARAM function call
+17 ; Supported IA #2051 reference $$FIND1^DIC function call
+18 ; Supported IA #2056 reference $$GET1^DIQ function call
+19 ; Controlled IA #4897 to read BUILD file (#9.6)
+20 ;
CONSOLID() ; check if this is a consolidated site or not
+1 ; return 0 = non-consolidated (normal) site
+2 ; return 1 = consolidated site
+3 ;
+4 ; code for the main VistA HIS
+5 QUIT $GET(^MAG(2006.1,"CONSOLIDATED"))="YES"
+6 ;
ACQDEV(MFGR,MODEL,SITE) ; get pointer to the Acquisition Device file
+1 ;--- name of acquisition device
NEW ACQDEV
+2 ;-- pointer to acquisition device file (#2006.04)
NEW ACQDEVP
+3 ;
+4 SET ACQDEV=$$UP^MAGDFCNV(MFGR_" ("_MODEL_")")
+5 SET ACQDEVP=$ORDER(^MAG(2006.04,"B",ACQDEV,""))
+6 ; create the entry
IF 'ACQDEVP
Begin DoDot:1
+7 ; serialize name generation code
LOCK +^MAG(2006.04,0):1E9
+8 IF '$DATA(^MAG(2006.04,0))
SET ^(0)="ACQUISITION DEVICE^2006.04^^"
+9 SET ACQDEVP=$PIECE(^MAG(2006.04,0),"^",3)+1
+10 ; 3rd piece is null
SET ^MAG(2006.04,ACQDEVP,0)=ACQDEV_"^"_SITE_"^"
+11 SET ^MAG(2006.04,"B",ACQDEV,ACQDEVP)=""
+12 SET $PIECE(^MAG(2006.04,0),"^",3)=ACQDEVP
+13 SET $PIECE(^MAG(2006.04,0),"^",4)=ACQDEVP
+14 ; clear the serial name generation code
LOCK -^MAG(2006.04,0)
End DoDot:1
+15 QUIT ACQDEVP
+16 ;
EQUIVGRP(P1,P2) ; see if two SOP Class pointers are in equivalent groups
+1 NEW G1,G2
+2 if '$GET(P1)
QUIT 0
+3 if '$GET(P2)
QUIT 0
+4 SET G1=$PIECE($GET(^MAG(2006.532,P1,0)),"^",3)
if G1=""
SET G1=P1
+5 SET G2=$PIECE($GET(^MAG(2006.532,P2,0)),"^",3)
if G2=""
SET G2=P2
+6 QUIT G1=G2
+7 ;
UP(X) ; special UPPER CASE function -- removes redundant blanks as well
+1 ; remove redundant blank
FOR
if X'[" "
QUIT
SET $EXTRACT(X,$FIND(X," ")-1)=""
+2 ; remove leading blank
IF $EXTRACT(X)=" "
SET $EXTRACT(X)=""
+3 ; remove trailing blank
IF $EXTRACT(X,$LENGTH(X))=" "
SET $EXTRACT(X,$LENGTH(X))=""
+4 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz^|","ABCDEFGHIJKLMNOPQRSTUVWXYZ~~")
+5 ;
STATNUMB() ; return numeric 3-digit station number for the VA
+1 NEW STATNUMB
+2 ; station number
SET STATNUMB=$$STA^XUAF4($$KSP^XUPARAM("INST"))
+3 ; station number is 3 digits, exclusive of any modifiers or full station number for IHS
+4 QUIT $SELECT($$ISIHS^MAGSPID():STATNUMB,1:$EXTRACT(STATNUMB,1,3))
+5 ;
DIVISION() ; return the user's hospital division - P333 PMK 01/13/2026
+1 NEW DIVISION
+2 ; user's logon division
SET DIVISION=$GET(DUZ(2),0)
+3 IF 'DIVISION
Begin DoDot:1
+4 SET DIVISION="-1,User's Division is not defined"
+5 QUIT
End DoDot:1
+6 QUIT DIVISION
+7 ;
GMRCACN(GMRCIEN) ; return a site-specific accession number for clinical specialties
+1 ; GMRCIEN is the CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
+2 ; return DILIST from FIND^DIC
NEW A
+3 ; accession number for a consult/procedure request
NEW ACNUMB
+4 ; date of exam
NEW EXAMDATE
+5 ; installation date for MAG*3.0*162, when site-specific accession numbers started
NEW P162DATE
+6 ; shouldn't use FIND1^DIC because it fails if the patch was installed multiple times
+7 ; P333 PMK 12/15/2022
DO FIND^DIC(9.7,"","17I;@","B","MAG*3.0*162","","","","","A")
+8 ; install complete date & time
SET P162DATE=$GET(A("DILIST","ID",1,17))
+9 SET EXAMDATE=$$GET1^DIQ(123,GMRCIEN,.01,"I")
+10 ; legacy accession number format
IF EXAMDATE<P162DATE
Begin DoDot:1
+11 ; Format: GMRC-<gmrcien>, where <gmrcien> is the internal entry number of the request
+12 SET ACNUMB="GMRC-"_GMRCIEN
+13 QUIT
End DoDot:1
+14 ; site-specific accession number format
IF '$TEST
Begin DoDot:1
+15 ; Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
+16 ; is the internal entry number of the request, up to 8 digits (100 million)
+17 SET ACNUMB=$$STATNUMB()_"-GMR-"_GMRCIEN
+18 QUIT
End DoDot:1
+19 QUIT ACNUMB
+20 ;
GMRCIEN(ACNUMB) ; return the GMRC IEN, given a consult/procedure accession number
+1 ; ACNUMB is the accession number for a consult/procedure request
+2 ; OLD Format: GMRC-<gmrcien>, where <gmrcien>is the internal entry number of the request
+3 ; New Format: <sss>-GMR-<gmrcien>, where <sss> is station number, and <gmrcien>
+4 ; is the internal entry number of the request, up to 8 digits (100 million)
+5 ; CPRS Consult Request Tracking GMRC IEN - REQUEST/CONSULTATION file(#123)
NEW GMRCIEN
+6 ; return the second piece
IF ACNUMB?1"GMRC-"1N.N
SET GMRCIEN=$PIECE(ACNUMB,"-",2)
+7 ; return the third piece
IF '$TEST
IF ACNUMB?1N.N1"-GMR-"1N.N
SET GMRCIEN=$PIECE(ACNUMB,"-",3)
+8 ; invalid consult request tracking accession number format
IF '$TEST
SET GMRCIEN=""
+9 QUIT GMRCIEN
+10 ;
HOSTNAME() ;
+1 QUIT $PIECE(##class(%SYS.System).GetNodeName(),".",1)
+2 ;
CHECKSUM ; interactive routine checksums - P333 PMK 06/06/2022
+1 NEW DEFAULT,DONE,HELP,PROMPT,ROUTINE,X
+2 ;
+3 ; switch to 132 character mode
USE $PRINCIPAL:132
+4 SET DEFAULT=""
+5 SET PROMPT="Checksums by Routine name or Patch number?"
+6 SET HELP(1)="Enter ""R"" to output the checksums for a set of named routines."
+7 SET HELP(2)="or ""P"" to output the checksums for all the routines in a patch."
+8 SET HELP(3)=""
+9 SET HELP(4)="Enter caret (""^"") to exit."
+10 ;
+11 SET DONE=0
FOR
Begin DoDot:1
+12 KILL ^TMP("MAG",$JOB,"ROUTINES")
+13 IF $$RP(PROMPT,DEFAULT,.X,.HELP)<0
SET DONE=-1
QUIT
+14 IF X="PATCH"
Begin DoDot:2
+15 DO PATCH
+16 SET DEFAULT="P"
+17 QUIT
End DoDot:2
+18 IF '$TEST
Begin DoDot:2
+19 DO ROUTINE
+20 SET DEFAULT="R"
+21 QUIT
End DoDot:2
+22 ;
+23 WRITE !
DO CHECKSUMS
+24 KILL ^TMP("MAG",$JOB,"ROUTINES")
+25 QUIT
End DoDot:1
if DONE
QUIT
+26 ; switch back to regular character mode
USE $PRINCIPAL:IOM
+27 QUIT
+28 ;
ROUTINE ; get a list of routines
+1 NEW DONE,LINE1,LINE2,R,SELECT,STATUS,STOP,X
+2 KILL ^TMP("MAG",$JOB,"ROUTINES")
+3 SET DONE=0
+4 FOR
Begin DoDot:1
+5 WRITE !,"Routine(s): "
+6 READ X:DTIME
+7 IF X=""
SET DONE=1
QUIT
+8 IF X="^"
SET DONE=-1
QUIT
+9 ; unselect the routine(s)
IF X?1"'".E
SET X=$EXTRACT(X,2,999)
SET SELECT=0
+10 ; select the routine(s)
IF '$TEST
SET SELECT=1
+11 ; strip off leading ^ in routine name
IF X?1"^".E
SET X=$EXTRACT(X,2,999)
+12 IF X?.E1"*"
Begin DoDot:2
+13 SET (R,X)=$PIECE(X,"*")
+14 SET STATUS=$$SAVERTN(R,SELECT)
+15 SET STOP=X_"ZZZ"
FOR
SET R=$ORDER(^ROUTINE(R))
if R=""
QUIT
if R]STOP
QUIT
Begin DoDot:3
+16 SET STATUS=$$SAVERTN(R,SELECT)
+17 QUIT
End DoDot:3
+18 QUIT
End DoDot:2
+19 ; set $T
IF '$TEST
IF $$SAVERTN(X,SELECT)
+20 IF '$TEST
WRITE " -- not on file"
+21 QUIT
End DoDot:1
if DONE
QUIT
+22 QUIT
+23 ;
SAVERTN(R,SELECT) ; save the routine info
+1 NEW EXISTS,LINE1,LINE2
+2 IF $DATA(^ROUTINE(R))
Begin DoDot:1
+3 ; select the routine
IF SELECT
Begin DoDot:2
+4 SET LINE1=$GET(^ROUTINE(R,0,1))
SET LINE2=$GET(^(2))
+5 SET ^TMP("MAG",$JOB,"ROUTINES",R)=$PIECE(LINE1,";",3)_"^"_$PIECE(LINE2,";",5)
+6 QUIT
End DoDot:2
+7 ; unselect the routine
IF '$TEST
Begin DoDot:2
+8 KILL ^TMP("MAG",$JOB,"ROUTINES",R)
+9 QUIT
End DoDot:2
+10 SET EXISTS=1
+11 QUIT
End DoDot:1
+12 IF '$TEST
SET EXISTS=0
+13 QUIT EXISTS
+14 ;
PATCH ; get a patch number
+1 NEW A,B,DONE,IEN,LINE1,LINE2,PLIST,PATCH,R,S,X
+2 SET DONE=0
+3 FOR
Begin DoDot:1
+4 WRITE !!,"Patch number: "
+5 READ X:DTIME
+6 IF "^"[X
SET DONE=1
QUIT
+7 IF (X'?1N.N)
IF (X'?1A.A1"*".1N.N.".".N1"*"1N.N)
WRITE " ???"
SET X="?"
+8 IF "?"[X
Begin DoDot:2
+9 WRITE !!,"Enter the full patch number or just the last digits for MAG*3.0*nnn"
+10 QUIT
End DoDot:2
QUIT
+11 IF X?1N.N
SET PATCH="MAG*3.0*"_X
+12 IF '$TEST
Begin DoDot:2
+13 SET PATCH=$$UP(X)
+14 IF $PIECE(PATCH,"*",2)?1N.N
SET $PIECE(PATCH,"*",2)=$PIECE(PATCH,"*",2)_".0"
+15 QUIT
End DoDot:2
+16 SET IEN=$$FIND1^DIC(9.6,"","BX",PATCH)
+17 IF IEN=0
WRITE " ??? No ",PATCH," patch"
QUIT
+18 DO GETS^DIQ(9.67,"9.8,"_IEN_",","10*","N","A","B")
+19 SET S=""
FOR
SET S=$ORDER(A(9.68,S))
if S=""
QUIT
Begin DoDot:2
+20 SET R=$GET(A(9.68,S,.01))
if R=""
QUIT
+21 SET LINE1=$GET(^ROUTINE(R,0,1))
SET LINE2=$GET(^(2))
+22 SET PLIST=$PIECE(LINE2,";",5)
+23 ; last edit date/time
SET ^TMP("MAG",$JOB,"ROUTINES",R)=$PIECE(LINE1,";",3)_"^"_PLIST
+24 QUIT
End DoDot:2
+25 SET DONE=1
+26 QUIT
End DoDot:1
if DONE
QUIT
+27 QUIT
+28 ;
CHECKSUMS ; output the checksums
+1 NEW R
+2 SET R=""
FOR
SET R=$ORDER(^TMP("MAG",$JOB,"ROUTINES",R))
if R=""
QUIT
Begin DoDot:1
+3 WRITE !,R,?10,$JUSTIFY($$CHK2(R),10)
+4 ; patch list
WRITE ?23,$PIECE($GET(^TMP("MAG",$JOB,"ROUTINES",R)),"^",1)
+5 ; last edit date/time
WRITE ?46,$PIECE($GET(^TMP("MAG",$JOB,"ROUTINES",R)),"^",2)
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
NOQUOTES(X) ; "Copy as path" has leading and trailing quotes - remove them
+1 ; P333 PMK 04/23/2025
IF $EXTRACT(X)=""""
IF $EXTRACT(X,$LENGTH(X))=""""
SET X=$EXTRACT(X,2,$LENGTH(X)-1)
+2 QUIT X
+3 ;
RP(PROMPT,DEFAULT,CHOICE,HELP) ; generic question driver
+1 NEW I,OK,X
+2 SET OK=0
FOR
Begin DoDot:1
+3 WRITE !!,PROMPT," "
IF $LENGTH($GET(DEFAULT))
WRITE DEFAULT,"// "
+4 READ X:DTIME
IF '$TEST
SET X="^"
+5 IF X=""
IF $LENGTH($GET(DEFAULT))
SET X=DEFAULT
WRITE X
+6 ; fails tests
IF X=""
IF '$LENGTH($GET(DEFAULT))
SET X="*"
+7 IF X["^"
SET CHOICE="^"
SET OK=-1
QUIT
+8 IF "Pp"[$EXTRACT(X)
SET CHOICE="PATCH"
SET OK=1
QUIT
+9 IF "Rr"[$EXTRACT(X)
SET CHOICE="ROUTINE"
SET OK=1
QUIT
+10 IF X["?"
IF $DATA(HELP)
Begin DoDot:2
+11 WRITE !
+12 FOR I=1:1
if '$DATA(HELP(I))
QUIT
WRITE !,HELP(I)
+13 QUIT
End DoDot:2
+14 IF '$TEST
WRITE " ???",!,"Please enter ""R"" for routines or ""P"" for a patch"
+15 QUIT
End DoDot:1
if OK
QUIT
+16 QUIT OK
+17 ;
CHK2(R) ; checksum algorithm for a routine
+1 NEW K,X,Y
+2 SET Y=0
+3 FOR K=1:1
SET X=$TEXT(+K^@R)
if X=""
QUIT
if K'=2
SET Y=Y+$$C2(X,K)
+4 QUIT Y
+5 ;
C2(X,K) ; checksum algorithm for a line
+1 NEW F,I,Y
+2 SET Y=0
+3 SET F=$FIND(X," ")
SET F=$SELECT($EXTRACT(X,F)'=";":$LENGTH(X),$EXTRACT(X,F+1)=";":$LENGTH(X),1:F-2)
+4 FOR I=1:1:F
SET Y=$ASCII(X,I)*(I+K)+Y
+5 QUIT Y
