- NURQRPT3 ;HIRMFO/YH-ROUTINE TO PRINT 10 STEP REPORT, PART 4 ;3/21/96
- ;;4.0;NURSING SERVICE;;Apr 25, 1997
- COMUN S NURQDC=$P($G(^NURQ(217,DA,8,D1,0)),"^",2) W:NURQDC'="" $E(NURQDC,4,5)_"-"_$E(NURQDC,6,7)_"-"_$E(NURQDC,2,3)
- Q
- REFER ;PRINT REFERENCE INFORMATION
- W !,"D. REFERENCE:" I $P($G(^NURQ(217,DA,9,0)),"^",3)>0 D
- .S NURQTXT=" " F D1=0:0 S D1=$O(^NURQ(217,DA,9,D1)) Q:D1'>0!$G(NUROUT) S NURQTXT=NURQTXT_" "_$P($G(^NURQ(217,DA,9,D1,0)),"^")
- .Q:$G(NUROUT) S NURQTXT(1)=$E(NURQB,1,3) D DIWP(.NURQTXT)
- ;PRINT OTHER QI INFORMATION
- Q:$G(NUROUT) W !,"E. OTHER:" I $P($G(^NURQ(217,DA,11,0)),"^",3)>0 D
- .S NURQTXT=" " F D1=0:0 S D1=$O(^NURQ(217,DA,11,D1)) Q:D1'>0!$G(NUROUT) S NURQTXT=NURQTXT_" "_$G(^NURQ(217,DA,11,D1,0))
- .Q:$G(NUROUT) S NURQTXT(1)=$E(NURQB,1,3) D DIWP(.NURQTXT)
- Q
- WRITE ;PRINT IMPORTANT FUNCTION TABLE
- ;NFUNC ARRAY CONTAINS TEXT OF IMPORTANT FUNCTIONS
- ;NCARE ARRAY CONTAINS TEXT OF STANDARD OF CARE_ASSOCIATESERVICE
- ;NPRACT ARRAY CONTAINS TEXT OF STANDARD OF PRACTICE_ASSOCIATE SERVICE
- ;NLEVL IS NUMBER OF ROWS
- Q:NLEVL'>0
- N NII F NII=1:1:NLEVL D:($Y>(IOSL-7)) HDR^NURQRPT0,FHEADR^NURQRPT0 Q:$G(NUROUT) W ! D
- .I $D(NFUNC(+NII)) W NFUNC(+NII)
- .I $D(NCARE(+NII)) W ?21,NCARE(+NII)
- .I $D(NPRACT(+NII)) W ?51,NPRACT(+NII)
- K NLEVL,NPRACT,NCARE,NFUNC Q
- DIWP(NTEXT) ;INPUT NTEXT CONTAINS WP TEXT
- ;^UTILITY($J,"W") CONTAINS THE ^DIWP OUTPUT
- K ^UTILITY($J) S X=NTEXT,DIWF="",DIWL=0,DIWR=76 D ^DIWP
- Q:'$D(^UTILITY($J,"W")) N NX,NY S NX=0 F S NX=$O(^UTILITY($J,"W",0,NX)) Q:NX'>0!$G(NUROUT) S NY=$G(^UTILITY($J,"W",0,NX,0)) D:($Y>(IOSL-7)) HDR^NURQRPT0 Q:$G(NUROUT) W !,$S(NX=1:NY,1:NTEXT(1)_NY)
- Q
- MERGE(NTEXT,NLEN) ;MERGE ^UTILITY($J,"W") TO NTEXT ARRAY WITH TEXT LENGTH<=NLEN
- N I S (NTEXT,I)=0 F S I=$O(^UTILITY($J,"W",0,I)) Q:I'>0 S I(1)=$G(^UTILITY($J,"W",0,I,0)) D
- .I $L(I(1))>NLEN D CUT Q
- .E S NTEXT=NTEXT+1,NTEXT(NTEXT)=I(1)
- Q
- CUT S NTEXT=NTEXT+1,NTEXT(NTEXT)=$E(I(1),1,NLEN),I(1)=$E(I(1),NLEN+1,40)
- I $L(I(1))>NLEN G CUT
- S NTEXT=NTEXT+1,NTEXT(NTEXT)=I(1)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HNURQRPT3 2049 printed Jan 18, 2025@03:22:23 Page 2
- NURQRPT3 ;HIRMFO/YH-ROUTINE TO PRINT 10 STEP REPORT, PART 4 ;3/21/96
- +1 ;;4.0;NURSING SERVICE;;Apr 25, 1997
- COMUN SET NURQDC=$PIECE($GET(^NURQ(217,DA,8,D1,0)),"^",2)
- if NURQDC'=""
- WRITE $EXTRACT(NURQDC,4,5)_"-"_$EXTRACT(NURQDC,6,7)_"-"_$EXTRACT(NURQDC,2,3)
- +1 QUIT
- REFER ;PRINT REFERENCE INFORMATION
- +1 WRITE !,"D. REFERENCE:"
- IF $PIECE($GET(^NURQ(217,DA,9,0)),"^",3)>0
- Begin DoDot:1
- +2 SET NURQTXT=" "
- FOR D1=0:0
- SET D1=$ORDER(^NURQ(217,DA,9,D1))
- if D1'>0!$GET(NUROUT)
- QUIT
- SET NURQTXT=NURQTXT_" "_$PIECE($GET(^NURQ(217,DA,9,D1,0)),"^")
- +3 if $GET(NUROUT)
- QUIT
- SET NURQTXT(1)=$EXTRACT(NURQB,1,3)
- DO DIWP(.NURQTXT)
- End DoDot:1
- +4 ;PRINT OTHER QI INFORMATION
- +5 if $GET(NUROUT)
- QUIT
- WRITE !,"E. OTHER:"
- IF $PIECE($GET(^NURQ(217,DA,11,0)),"^",3)>0
- Begin DoDot:1
- +6 SET NURQTXT=" "
- FOR D1=0:0
- SET D1=$ORDER(^NURQ(217,DA,11,D1))
- if D1'>0!$GET(NUROUT)
- QUIT
- SET NURQTXT=NURQTXT_" "_$GET(^NURQ(217,DA,11,D1,0))
- +7 if $GET(NUROUT)
- QUIT
- SET NURQTXT(1)=$EXTRACT(NURQB,1,3)
- DO DIWP(.NURQTXT)
- End DoDot:1
- +8 QUIT
- WRITE ;PRINT IMPORTANT FUNCTION TABLE
- +1 ;NFUNC ARRAY CONTAINS TEXT OF IMPORTANT FUNCTIONS
- +2 ;NCARE ARRAY CONTAINS TEXT OF STANDARD OF CARE_ASSOCIATESERVICE
- +3 ;NPRACT ARRAY CONTAINS TEXT OF STANDARD OF PRACTICE_ASSOCIATE SERVICE
- +4 ;NLEVL IS NUMBER OF ROWS
- +5 if NLEVL'>0
- QUIT
- +6 NEW NII
- FOR NII=1:1:NLEVL
- if ($Y>(IOSL-7))
- DO HDR^NURQRPT0
- DO FHEADR^NURQRPT0
- if $GET(NUROUT)
- QUIT
- WRITE !
- Begin DoDot:1
- +7 IF $DATA(NFUNC(+NII))
- WRITE NFUNC(+NII)
- +8 IF $DATA(NCARE(+NII))
- WRITE ?21,NCARE(+NII)
- +9 IF $DATA(NPRACT(+NII))
- WRITE ?51,NPRACT(+NII)
- End DoDot:1
- +10 KILL NLEVL,NPRACT,NCARE,NFUNC
- QUIT
- DIWP(NTEXT) ;INPUT NTEXT CONTAINS WP TEXT
- +1 ;^UTILITY($J,"W") CONTAINS THE ^DIWP OUTPUT
- +2 KILL ^UTILITY($JOB)
- SET X=NTEXT
- SET DIWF=""
- SET DIWL=0
- SET DIWR=76
- DO ^DIWP
- +3 if '$DATA(^UTILITY($JOB,"W"))
- QUIT
- NEW NX,NY
- SET NX=0
- FOR
- SET NX=$ORDER(^UTILITY($JOB,"W",0,NX))
- if NX'>0!$GET(NUROUT)
- QUIT
- SET NY=$GET(^UTILITY($JOB,"W",0,NX,0))
- if ($Y>(IOSL-7))
- DO HDR^NURQRPT0
- if $GET(NUROUT)
- QUIT
- WRITE !,$SELECT(NX=1:NY,1:NTEXT(1)_NY)
- +4 QUIT
- MERGE(NTEXT,NLEN) ;MERGE ^UTILITY($J,"W") TO NTEXT ARRAY WITH TEXT LENGTH<=NLEN
- +1 NEW I
- SET (NTEXT,I)=0
- FOR
- SET I=$ORDER(^UTILITY($JOB,"W",0,I))
- if I'>0
- QUIT
- SET I(1)=$GET(^UTILITY($JOB,"W",0,I,0))
- Begin DoDot:1
- +2 IF $LENGTH(I(1))>NLEN
- DO CUT
- QUIT
- +3 IF '$TEST
- SET NTEXT=NTEXT+1
- SET NTEXT(NTEXT)=I(1)
- End DoDot:1
- +4 QUIT
- CUT SET NTEXT=NTEXT+1
- SET NTEXT(NTEXT)=$EXTRACT(I(1),1,NLEN)
- SET I(1)=$EXTRACT(I(1),NLEN+1,40)
- +1 IF $LENGTH(I(1))>NLEN
- GOTO CUT
- +2 SET NTEXT=NTEXT+1
- SET NTEXT(NTEXT)=I(1)
- +3 QUIT