MCARD1 ;WISC/TJK,FDJW,JA-FILL V() AFTER SELECTION ;7/22/96 14:55
;;2.3;Medicine;;09/13/1996
S DJSW2=1
S1 S DJ14=-1,DJ9=V,DJ8=DJN
S:'$D(DJST) DJST=1 I DJST=1 S ^TMP($J,"DJST",1,"DA")=W(DJ9),^TMP($J,"DJST",1,"SC")=DJN,^TMP($J,"DJST",1,"LOC")="",^TMP($J,"DJST",1,"DIC")=DIC,^TMP($J,"DJST",1,"DD")=DJDD,^TMP($J,"DJST",1,"GN")=""
F V=DJF-.01:0 S V=$O(DJJ(V)) S:V="" V=-1 Q:V<0!(V>DJL) S DJ16=$P(DJJ(V),U,4) D:DJ16["M" M D:DJ16'["M" S
S V=DJ9,@$P(DJJ(V),U,2) K DJ3,DJ14,DJ5,DJ16,DJ7,DJ8,DJ9,Y,DJZ,DJS
Q
S S DJ7=$P(DJJ(V),U,3) Q:DJ7=""!$P(DJJ(V),U,4)!(DJ7<0) I DJ7=.001 S V(V)=+Y G SQ
S:DJST=1 D0=DA D:DJST>1 COMP
I $P(DJJ(V),U,4)["C" S DJ16=$P(DJJ(V),U,4),@$P(DJJ(V),U,2) G SQ3
S DJ16=$P(^DD(DJDD,DJ7,0),U,4),DJ5=$P(DJ16,";",2),DJ16=$P(DJ16,";",1) G:DJ5=" " SQ
S:DJ14'=DJ16 DJ14=DJ16,DJ3=$S($D(@(DIC_"+W(DJ9),DJ16)")):^(DJ16),1:"") S @("V(V)=$"_$S(DJ5:"P",1:"E")_"(DJ3,"_$S(DJ5:"U,DJ5)",1:+$E(DJ5,2,9)_","_$P(DJ5,",",2)_")"))
SQ Q:$G(V(V))=""!'$D(DJJ(V)) S DJ16=$P(DJJ(V),U,4),@$P(DJJ(V),U,2)
SQ1 I DJ16["D" S Y=V(V) D DT S V(V)=Y K DJ5 G E
I DJ16["P",$D(@("^"_$P(^DD(DJDD,DJ7,0),U,3)_"V(V),0)")) S V(V)=$P(^(0),U,1) D P G E
SQ3 I DJ16["C" X $P(^DD(DJDD,DJ7,0),U,5,99) D:$E(X)=" " BLANK S V(V)=X S:+X=0 V(V)="" G:DJ16["D" SQ1
I DJ16["S" S DJS=$P(^DD(DJDD,DJ7,0),U,3) F DJK=1:1 S DJZ=$P(DJS,";",DJK) Q:DJZ="" I $P(DJZ,":",1)=V(V) S V(V)=$P(DJZ,":",2)
E ; display the datum
X XY
IF V(V)'="" D ; no need to display a blank
. D O ; execute the output transform
. S V(V)=$E(V(V),1,+DJJ(V))
. IF DJSW2 D ; display switch is on
.. W DJHIN
.. X XY
.. ;W V(V),DJLIN
.. S DJDB=""
.. I DJJ(V)-$L(V(V)) S $P(DJDB," ",DJJ(V)-$L(V(V)))=" "
.. ;I $L(DJDB) W DJDB
.. S DJDB=V(V)_DJDB
.. ;
.. ; do we have more than 80 characters to write?
.. I $L(DJDB)'>80 W DJDB ; no
.. E W $E(DJDB,1,80-DX),!,$E(DJDB,80-DX+1,$L(DJDB)) ; yes
.. W DJLIN
.. K DJDB
.. Q
. ;END IF
. ;
. Q
;END IF
;
I DJ7=.01&(DJ16'["M") S ^TMP($J,"DJST",DJST,"TITLE")=$P(^DD(DJDD,.01,0),"^",1)_":"_V(V),^TMP($J,"DJST",DJST-1,"KEY")=V(V)
Q
P ;
S DJZ=+$P($P(^DD(DJDD,DJ7,0),"^",2),"P",2) Q:$P(^DD(DJZ,.01,0),"^",2)'["P"
P1 I $D(@("^"_$P(^DD(DJZ,.01,0),U,3)_"V(V),0)")) S V(V)=$P(^(0),U,1)
S DJZ=+$P($P(^DD(DJZ,.01,0),"^",2),"P",2) Q:$P(^DD(DJZ,.01,0),"^",2)'["P" G P1
;
M S @$P(DJJ(V),U,2),DJM1=$P($P(^DD(DJDD,$P(DJJ(V),U,3),0),U,4),";",1),DJQ1="""",DJM1=$S(DJM1'=+DJM1:DJQ1_DJM1_DJQ1,1:DJM1),DJM2=$S($D(@(DIC_+W(DJ9)_","_DJM1_")")):@(DIC_+W(DJ9)_","_DJM1_",0)"),1:"")
S DJDD1=+$P(DJJ(V),U,4) I DJM2="" S V(V)="",DJM3="" G QQ
; Naked reference in next line is to @(DIC_+W(DJ9)_","_DJM1_",")
S DJM3=$P(DJM2,U,3) S:DJM3>0 V(V)=$P(^(DJM3,0),U,1) S:DJM3<1!(DJM3="") V(V)="" S DJ16=$P(^DD(DJDD1,.01,0),U,2)
S DJDDS=DJDD,DJDD=DJDD1
S DJ7=.01 D:DJM3>0 SQ1 S DJDD=DJDDS
QQ S V(V,"DA")=DJM3,V(V,"GN")=$P(DJM1,";",1),V(V,"DD")=$P($P(DJJ(V),U,4),"M",1),Y=-1 K DJDD1,DJ7,DJM1,DJM2,DJM3,DJQ1,DJDDS Q
COMP F DJK=0:1:DJST-2 S @("D"_DJK)=^TMP($J,"DJST",DJK+1,"DA")
S DJK=DJST-1,@("D"_DJK)=DA Q
DT S:Y Y=$S($E(Y,4,5):$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$E(Y,4,5))_" ",1:"")_$S($E(Y,6,7):+$E(Y,6,7)_",",1:"")_($E(Y,1,3)+1700)_$P("@"_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),"^",Y[".")
Q
O ;EX OUTPUT TRANSFORM
I $D(^DD(DJDD,DJ7,2)) S Y=V(V) X ^(2) S V(V)=Y Q
Q
EN ;DO NOT PRINT V(V)
S DJSW2=0 G S1
BLANK F I=1:1:$L(X) Q:$E(X,I)'=" "
S X=$E(X,I,$L(X))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCARD1 3493 printed Oct 16, 2024@18:13:01 Page 2
MCARD1 ;WISC/TJK,FDJW,JA-FILL V() AFTER SELECTION ;7/22/96 14:55
+1 ;;2.3;Medicine;;09/13/1996
+2 SET DJSW2=1
S1 SET DJ14=-1
SET DJ9=V
SET DJ8=DJN
+1 if '$DATA(DJST)
SET DJST=1
IF DJST=1
SET ^TMP($JOB,"DJST",1,"DA")=W(DJ9)
SET ^TMP($JOB,"DJST",1,"SC")=DJN
SET ^TMP($JOB,"DJST",1,"LOC")=""
SET ^TMP($JOB,"DJST",1,"DIC")=DIC
SET ^TMP($JOB,"DJST",1,"DD")=DJDD
SET ^TMP($JOB,"DJST",1,"GN")=""
+2 FOR V=DJF-.01:0
SET V=$ORDER(DJJ(V))
if V=""
SET V=-1
if V<0!(V>DJL)
QUIT
SET DJ16=$PIECE(DJJ(V),U,4)
if DJ16["M"
DO M
if DJ16'["M"
DO S
+3 SET V=DJ9
SET @$PIECE(DJJ(V),U,2)
KILL DJ3,DJ14,DJ5,DJ16,DJ7,DJ8,DJ9,Y,DJZ,DJS
+4 QUIT
S SET DJ7=$PIECE(DJJ(V),U,3)
if DJ7=""!$PIECE(DJJ(V),U,4)!(DJ7<0)
QUIT
IF DJ7=.001
SET V(V)=+Y
GOTO SQ
+1 if DJST=1
SET D0=DA
if DJST>1
DO COMP
+2 IF $PIECE(DJJ(V),U,4)["C"
SET DJ16=$PIECE(DJJ(V),U,4)
SET @$PIECE(DJJ(V),U,2)
GOTO SQ3
+3 SET DJ16=$PIECE(^DD(DJDD,DJ7,0),U,4)
SET DJ5=$PIECE(DJ16,";",2)
SET DJ16=$PIECE(DJ16,";",1)
if DJ5=" "
GOTO SQ
+4 if DJ14'=DJ16
SET DJ14=DJ16
SET DJ3=$SELECT($DATA(@(DIC_"+W(DJ9),DJ16)")):^(DJ16),1:"")
SET @("V(V)=$"_$SELECT(DJ5:"P",1:"E")_"(DJ3,"_$SELECT(DJ5:"U,DJ5)",1:+$EXTRACT(DJ5,2,9)_","_$PIECE(DJ5,",",2)_")"))
SQ if $GET(V(V))=""!'$DATA(DJJ(V))
QUIT
SET DJ16=$PIECE(DJJ(V),U,4)
SET @$PIECE(DJJ(V),U,2)
SQ1 IF DJ16["D"
SET Y=V(V)
DO DT
SET V(V)=Y
KILL DJ5
GOTO E
+1 IF DJ16["P"
IF $DATA(@("^"_$PIECE(^DD(DJDD,DJ7,0),U,3)_"V(V),0)"))
SET V(V)=$PIECE(^(0),U,1)
DO P
GOTO E
SQ3 IF DJ16["C"
XECUTE $PIECE(^DD(DJDD,DJ7,0),U,5,99)
if $EXTRACT(X)=" "
DO BLANK
SET V(V)=X
if +X=0
SET V(V)=""
if DJ16["D"
GOTO SQ1
+1 IF DJ16["S"
SET DJS=$PIECE(^DD(DJDD,DJ7,0),U,3)
FOR DJK=1:1
SET DJZ=$PIECE(DJS,";",DJK)
if DJZ=""
QUIT
IF $PIECE(DJZ,":",1)=V(V)
SET V(V)=$PIECE(DJZ,":",2)
E ; display the datum
+1 XECUTE XY
+2 ; no need to display a blank
IF V(V)'=""
Begin DoDot:1
+3 ; execute the output transform
DO O
+4 SET V(V)=$EXTRACT(V(V),1,+DJJ(V))
+5 ; display switch is on
IF DJSW2
Begin DoDot:2
+6 WRITE DJHIN
+7 XECUTE XY
+8 ;W V(V),DJLIN
+9 SET DJDB=""
+10 IF DJJ(V)-$LENGTH(V(V))
SET $PIECE(DJDB," ",DJJ(V)-$LENGTH(V(V)))=" "
+11 ;I $L(DJDB) W DJDB
+12 SET DJDB=V(V)_DJDB
+13 ;
+14 ; do we have more than 80 characters to write?
+15 ; no
IF $LENGTH(DJDB)'>80
WRITE DJDB
+16 ; yes
IF '$TEST
WRITE $EXTRACT(DJDB,1,80-DX),!,$EXTRACT(DJDB,80-DX+1,$LENGTH(DJDB))
+17 WRITE DJLIN
+18 KILL DJDB
+19 QUIT
End DoDot:2
+20 ;END IF
+21 ;
+22 QUIT
End DoDot:1
+23 ;END IF
+24 ;
+25 IF DJ7=.01&(DJ16'["M")
SET ^TMP($JOB,"DJST",DJST,"TITLE")=$PIECE(^DD(DJDD,.01,0),"^",1)_":"_V(V)
SET ^TMP($JOB,"DJST",DJST-1,"KEY")=V(V)
+26 QUIT
P ;
+1 SET DJZ=+$PIECE($PIECE(^DD(DJDD,DJ7,0),"^",2),"P",2)
if $PIECE(^DD(DJZ,.01,0),"^",2)'["P"
QUIT
P1 IF $DATA(@("^"_$PIECE(^DD(DJZ,.01,0),U,3)_"V(V),0)"))
SET V(V)=$PIECE(^(0),U,1)
+1 SET DJZ=+$PIECE($PIECE(^DD(DJZ,.01,0),"^",2),"P",2)
if $PIECE(^DD(DJZ,.01,0),"^",2)'["P"
QUIT
GOTO P1
+2 ;
M SET @$PIECE(DJJ(V),U,2)
SET DJM1=$PIECE($PIECE(^DD(DJDD,$PIECE(DJJ(V),U,3),0),U,4),";",1)
SET DJQ1=""""
SET DJM1=$SELECT(DJM1'=+DJM1:DJQ1_DJM1_DJQ1,1:DJM1)
SET DJM2=$SELECT($DATA(@(DIC_+W(DJ9)_","_DJM1_")")):@(DIC_+W(DJ9)_","_DJM1_",0)"),1:"")
+1 SET DJDD1=+$PIECE(DJJ(V),U,4)
IF DJM2=""
SET V(V)=""
SET DJM3=""
GOTO QQ
+2 ; Naked reference in next line is to @(DIC_+W(DJ9)_","_DJM1_",")
+3 SET DJM3=$PIECE(DJM2,U,3)
if DJM3>0
SET V(V)=$PIECE(^(DJM3,0),U,1)
if DJM3<1!(DJM3="")
SET V(V)=""
SET DJ16=$PIECE(^DD(DJDD1,.01,0),U,2)
+4 SET DJDDS=DJDD
SET DJDD=DJDD1
+5 SET DJ7=.01
if DJM3>0
DO SQ1
SET DJDD=DJDDS
QQ SET V(V,"DA")=DJM3
SET V(V,"GN")=$PIECE(DJM1,";",1)
SET V(V,"DD")=$PIECE($PIECE(DJJ(V),U,4),"M",1)
SET Y=-1
KILL DJDD1,DJ7,DJM1,DJM2,DJM3,DJQ1,DJDDS
QUIT
COMP FOR DJK=0:1:DJST-2
SET @("D"_DJK)=^TMP($JOB,"DJST",DJK+1,"DA")
+1 SET DJK=DJST-1
SET @("D"_DJK)=DA
QUIT
DT if Y
SET Y=$SELECT($EXTRACT(Y,4,5):$PIECE("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC","^",+$EXTRACT(Y,4,5))_" ",1:"")_$SELECT($EXTRACT(Y,6,7):+$EXTRACT(Y,6,7)_",",1:"")_($EXTRACT(Y,1,3)+1700)_$PIECE("@"_$EXTRACT(Y_0,9,10)_":"_...
... $EXTRACT(Y_"000",11,12),"^",Y[".")
+1 QUIT
O ;EX OUTPUT TRANSFORM
+1 IF $DATA(^DD(DJDD,DJ7,2))
SET Y=V(V)
XECUTE ^(2)
SET V(V)=Y
QUIT
+2 QUIT
EN ;DO NOT PRINT V(V)
+1 SET DJSW2=0
GOTO S1
BLANK FOR I=1:1:$LENGTH(X)
if $EXTRACT(X,I)'=" "
QUIT
+1 SET X=$EXTRACT(X,I,$LENGTH(X))
+2 QUIT
