- 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 Feb 18, 2025@23:43:20 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