MCRH3 ; HOIFO/NCA - RHEUMATOLOGY Patient Background Info ;7/3/96 09:13
;;2.3;Medicine;**35**;09/13/1996
; Reference IA #10088
EN1 ; Get the Medicine View File #697.3 entry.
N MCARC,MCHDR,MCRHS,MCARR,MCLP,MCLP1,MCX,MCTR,MCNAM,MCCOL,MCROW
S (MCARC,MCCOL,MCROW)=0
S MCRHS=$O(^MCAR(697.3,"B",MCRHB,0)) I 'MCRHS W !!,"No Medicine View Screen for Rheumatology Patient Background." Q
S MCHDR=$P($G(^MCAR(697.3,MCRHS,0)),"^",7)
S MCLP=0 F S MCLP=$O(^MCAR(697.3,MCRHS,1,"A",MCLP)) Q:MCLP<1 D
.S MCLP1=0 F S MCLP1=$O(^MCAR(697.3,MCRHS,1,"A",MCLP,MCLP1)) Q:MCLP1<1 S MCARR(MCLP)=MCLP1
S MCLP=0 F S MCLP=$O(MCARR(MCLP)) Q:MCLP<1 S MCX=$G(MCARR(MCLP)),MCARR(MCLP)=$G(^MCAR(697.3,MCRHS,1,MCX,0))
S X="IOINHI;IOINLOW" D ENDR^%ZISS
W @IOF,?17,MCHDR S MCLP=0 F S MCLP=$O(MCARR(MCLP)) Q:MCLP<1 S MCX=$G(MCARR(MCLP)) D
.S MCNAM=$P(MCX,"^"),MCCOL=$P(MCX,"^",2)
.S MCROW=$P(MCCOL,","),MCCOL=$P(MCCOL,",",2)
.S MCROW=$P(MCROW,"DY=",2),MCCOL=$P(MCCOL,"DX=",2)
.I MCROW'=MCARC F MCTR=1:1 Q:MCARC=MCROW W ! S MCARC=MCARC+1
.W IOINHI
.W ?MCCOL,MCLP
.W IOINLOW
.W " ",MCNAM_$S($E(MCNAM,$L(MCNAM))=":":"",1:":")
.W IOINHI
.W $G(MCARR1(MCLP))
.W IOINLOW
W !!,"FUNCTION: "
W !!," ^ -- Quit"
W !," N -- New record",!
K DIR S DIR(0)="SOA^N:New Record",DIR("A")="FUNCTION:",DIR("B")="N" D ^DIR Q:$D(DIRUT)!($D(DIROUT))
K DIRUT,DIROUT,IOINLOW,IOINHI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCRH3 1388 printed Apr 09, 2024@21:17:55 Page 2
MCRH3 ; HOIFO/NCA - RHEUMATOLOGY Patient Background Info ;7/3/96 09:13
+1 ;;2.3;Medicine;**35**;09/13/1996
+2 ; Reference IA #10088
EN1 ; Get the Medicine View File #697.3 entry.
+1 NEW MCARC,MCHDR,MCRHS,MCARR,MCLP,MCLP1,MCX,MCTR,MCNAM,MCCOL,MCROW
+2 SET (MCARC,MCCOL,MCROW)=0
+3 SET MCRHS=$ORDER(^MCAR(697.3,"B",MCRHB,0))
IF 'MCRHS
WRITE !!,"No Medicine View Screen for Rheumatology Patient Background."
QUIT
+4 SET MCHDR=$PIECE($GET(^MCAR(697.3,MCRHS,0)),"^",7)
+5 SET MCLP=0
FOR
SET MCLP=$ORDER(^MCAR(697.3,MCRHS,1,"A",MCLP))
if MCLP<1
QUIT
Begin DoDot:1
+6 SET MCLP1=0
FOR
SET MCLP1=$ORDER(^MCAR(697.3,MCRHS,1,"A",MCLP,MCLP1))
if MCLP1<1
QUIT
SET MCARR(MCLP)=MCLP1
End DoDot:1
+7 SET MCLP=0
FOR
SET MCLP=$ORDER(MCARR(MCLP))
if MCLP<1
QUIT
SET MCX=$GET(MCARR(MCLP))
SET MCARR(MCLP)=$GET(^MCAR(697.3,MCRHS,1,MCX,0))
+8 SET X="IOINHI;IOINLOW"
DO ENDR^%ZISS
+9 WRITE @IOF,?17,MCHDR
SET MCLP=0
FOR
SET MCLP=$ORDER(MCARR(MCLP))
if MCLP<1
QUIT
SET MCX=$GET(MCARR(MCLP))
Begin DoDot:1
+10 SET MCNAM=$PIECE(MCX,"^")
SET MCCOL=$PIECE(MCX,"^",2)
+11 SET MCROW=$PIECE(MCCOL,",")
SET MCCOL=$PIECE(MCCOL,",",2)
+12 SET MCROW=$PIECE(MCROW,"DY=",2)
SET MCCOL=$PIECE(MCCOL,"DX=",2)
+13 IF MCROW'=MCARC
FOR MCTR=1:1
if MCARC=MCROW
QUIT
WRITE !
SET MCARC=MCARC+1
+14 WRITE IOINHI
+15 WRITE ?MCCOL,MCLP
+16 WRITE IOINLOW
+17 WRITE " ",MCNAM_$SELECT($EXTRACT(MCNAM,$LENGTH(MCNAM))=":":"",1:":")
+18 WRITE IOINHI
+19 WRITE $GET(MCARR1(MCLP))
+20 WRITE IOINLOW
End DoDot:1
+21 WRITE !!,"FUNCTION: "
+22 WRITE !!," ^ -- Quit"
+23 WRITE !," N -- New record",!
+24 KILL DIR
SET DIR(0)="SOA^N:New Record"
SET DIR("A")="FUNCTION:"
SET DIR("B")="N"
DO ^DIR
if $DATA(DIRUT)!($DATA(DIROUT))
QUIT
+25 KILL DIRUT,DIROUT,IOINLOW,IOINHI
+26 QUIT
