NURSDFFS.m

NURSDFFS ;HIRMFO/RM-FILE FIELD STRUCTURES FOR NURSING FILES ;AUGUST 1986

 ;;4.0;NURSING SERVICE;;Apr 25, 1997

 Q:'$D(^DIC(213.9,1,"OFF"))  Q:$P(^DIC(213.9,1,"OFF"),"^",1)=1

 D DT^DICRW S NURQUEUE=0

 W ! S ZTRTN="EN1^NURSDFFS" D EN7^NURSUT0 G:POP!($D(ZTSK)) QUIT

EN1 ; ENTRY TO BEGIN PRINTING

 S IOP=ION D ^%ZIS K IOP U IO

 F NURSFILE=209.99999:0 S NURSFILE=$O(^DIC(NURSFILE)) Q:NURSFILE'<220!(NURSFILE="")  S STACK=1,NURSPACE="",NURSPAGE=1,NURSLINE=0 D PRNTFLDS

QUIT D CLOSE^NURSUT1,^NURSKILL

 Q

PRNTFLDS ; PRINTS LINES FOR FIELDS

 D:(STACK=1)!(NURSLINE>55) HEADER

 F NURSFLD=0:0 S NURSFLD=$O(^DD(NURSFILE,NURSFLD)) Q:NURSFLD'>0  D PRINTLN,POPSTACK,CKSUB

 Q

CKSUB ; CHECKS FOR THE EXISTENCE OF SUB-FIELDS AND PRINTS THEM OUT (RECURSIVE)

 S STACK=STACK+1,NURSPACE="       "_NURSPACE

 F NURSFILE=NURSFILE:0 S NURSFILE=$O(^DD(NURSFILE(STACK-1),"SB",NURSFILE)) Q:NURSFILE'>0  S NURSFLD=$O(^DD(NURSFILE(STACK-1),"SB",NURSFILE,"")) I NURSFLD=NURSFLD(STACK-1) D PRNTFLDS

 S STACK=STACK-1,NURSFLD=NURSFLD(STACK),NURSFILE=NURSFILE(STACK),NURSPACE=$E(NURSPACE,8,$L(NURSPACE))

 K NURSFLD(STACK),NURSFILE(STACK)

 Q

PRINTLN ; PRINT A LINE

 D FIELD^DID(NURSFILE,NURSFLD,"","LABEL","NURSFLNM","") S NURSLINE=NURSLINE+1

 W !,NURSPACE_NURSFLD_$E("       ",1,7-$L(NURSFLD))_NURSFLNM("LABEL")

 Q

POPSTACK ; ADD ONE MORE ITEM TO STACK

 S NURSFLD(STACK)=NURSFLD,NURSFILE(STACK)=NURSFILE

 Q

HEADER ; PRINT HEADING FOR EACH FILE

 I '$D(NURSFILE(1)) S NURSFIL1=NURSFILE

 E  S NURSFIL1=NURSFILE(1)

 W @IOF

 W !!,$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),?22,"FILE FIELD STRUCTURE FOR FILE #"_NURSFIL1,?70,"PAGE: ",NURSPAGE,!,$$REPEAT^XLFSTR("-",80),!

 S NURSLINE=0,NURSPAGE=NURSPAGE+1

 Q

NURSDFFS  ;HIRMFO/RM-FILE FIELD STRUCTURES FOR NURSING FILES ;AUGUST 1986

 +1       ;;4.0;NURSING SERVICE;;Apr 25, 1997

 +2        IF '$DATA(^DIC(213.9,1,"OFF"))

               QUIT 

           IF $PIECE(^DIC(213.9,1,"OFF"),"^",1)=1

               QUIT 

 +3        DO DT^DICRW

           SET NURQUEUE=0

 +4        WRITE !

           SET ZTRTN="EN1^NURSDFFS"

           DO EN7^NURSUT0

           IF POP!($DATA(ZTSK))

               GOTO QUIT

EN1       ; ENTRY TO BEGIN PRINTING

 +1        SET IOP=ION

           DO ^%ZIS

           KILL IOP

           USE IO

 +2        FOR NURSFILE=209.99999:0

               SET NURSFILE=$ORDER(^DIC(NURSFILE))

               IF NURSFILE'<220!(NURSFILE="")

                   QUIT 

               SET STACK=1

               SET NURSPACE=""

               SET NURSPAGE=1

               SET NURSLINE=0

               DO PRNTFLDS

QUIT       DO CLOSE^NURSUT1

           DO ^NURSKILL

 +1        QUIT 

PRNTFLDS  ; PRINTS LINES FOR FIELDS

 +1        IF (STACK=1)!(NURSLINE>55)

               DO HEADER

 +2        FOR NURSFLD=0:0

               SET NURSFLD=$ORDER(^DD(NURSFILE,NURSFLD))

               IF NURSFLD'>0

                   QUIT 

               DO PRINTLN

               DO POPSTACK

               DO CKSUB

 +3        QUIT 

CKSUB     ; CHECKS FOR THE EXISTENCE OF SUB-FIELDS AND PRINTS THEM OUT (RECURSIVE)

 +1        SET STACK=STACK+1

           SET NURSPACE="       "_NURSPACE

 +2        FOR NURSFILE=NURSFILE:0

               SET NURSFILE=$ORDER(^DD(NURSFILE(STACK-1),"SB",NURSFILE))

               IF NURSFILE'>0

                   QUIT 

               SET NURSFLD=$ORDER(^DD(NURSFILE(STACK-1),"SB",NURSFILE,""))

               IF NURSFLD=NURSFLD(STACK-1)

                   DO PRNTFLDS

 +3        SET STACK=STACK-1

           SET NURSFLD=NURSFLD(STACK)

           SET NURSFILE=NURSFILE(STACK)

           SET NURSPACE=$EXTRACT(NURSPACE,8,$LENGTH(NURSPACE))

 +4        KILL NURSFLD(STACK),NURSFILE(STACK)

 +5        QUIT 

PRINTLN   ; PRINT A LINE

 +1        DO FIELD^DID(NURSFILE,NURSFLD,"","LABEL","NURSFLNM","")

           SET NURSLINE=NURSLINE+1

 +2        WRITE !,NURSPACE_NURSFLD_$EXTRACT("       ",1,7-$LENGTH(NURSFLD))_NURSFLNM("LABEL")

 +3        QUIT 

POPSTACK  ; ADD ONE MORE ITEM TO STACK

 +1        SET NURSFLD(STACK)=NURSFLD

           SET NURSFILE(STACK)=NURSFILE

 +2        QUIT 

HEADER    ; PRINT HEADING FOR EACH FILE

 +1        IF '$DATA(NURSFILE(1))

               SET NURSFIL1=NURSFILE

 +2       IF '$TEST

               SET NURSFIL1=NURSFILE(1)

 +3        WRITE @IOF

 +4        WRITE !!,$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),?22,"FILE FIELD STRUCTURE FOR FILE #"_NURSFIL1,?70,"PAGE: ",NURSPAGE,!,$$REPEAT^XLFSTR("-",80),!

 +5        SET NURSLINE=0

           SET NURSPAGE=NURSPAGE+1

 +6        QUIT