AGRHI1.m

AGRHI1 ; IHS/ASDS/EFG - RESTRICTED HEALTH REPORT ;   

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 ;

 ;THIS ROUTINE WILL CREATE A REPORT BASED ON THE RESTIRCTED

 ;HEALTH INFORMATION FILE

 ;

 Q

EN ;EP

 K AG("F1")

 D BEGDT

 Q:$D(DTOUT)!$D(DUOUT)

 S AGQ("RC")="PROCESS^AGRHI1"

 S AGQ("RP")="PRINT^AGRHI1"

 S AGQ("RX")="EXIT^AGRHI1"

 S AGQ("NS")="AG"

 D ^AGDBQUE

 Q

BEGDT ;PROMPT FOR BEGINNING DATE OF ENTRY

 S AG("PAGE")=0

 K DIR,X,Y

 S DIR(0)="D"

 S DIR("A")="Please enter a beginning Date Of Entry. "

 D ^DIR

 Q:$D(DTOUT)!$D(DUOUT)

 S X=Y S BDT=+Y D DD^%DT S AG("BEGDT")=Y

ENDDT ;PROMPT FOR ENDING DATE OF ENTRY

 K DIR,X,Y

 S DIR(0)="D"

 S DIR("A")="Please enter an ending Date Of Entry. "

 D ^DIR

 Q:$D(DTOUT)!$D(DUOUT)

 S X=Y S EDT=+Y D DD^%DT S AG("ENDDT")=Y

 Q

HDR ;PRINT THE PAGE HEADER

 W @IOF

 S AG("PAGE")=AG("PAGE")+1

 W !,?19,"*** RESTRICTED HEALTH INFORMATION REPORT ***"

 W ?70,"Page ",AG("PAGE")

 S AG("RHIDT")=$$NOW^XLFDT

 S AG("DSPDAT")=$E(AG("RHIDT"),4,5)_"/"_$E(AG("RHIDT"),6,7)_"/"_($E(AG("RHIDT"),1,3)+1700)_"  "_$E(AG("RHIDT"),9,10)_":"_$E(AG("RHIDT"),11,12)

 S AG("DSPDAT")="RUN DATE/TIME : "_AG("DSPDAT")

 W !,?(80-$L(AG("DSPDAT"))/2),AG("DSPDAT")

 W !!,"BEGINNING ENTRY DATE: ",AG("BEGDT")

 W !,"ENDING ENTRY DATE:    ",AG("ENDDT")

 W !!,"PERSON",?18,"DATE OF"

 W !,"ENTERING",?19,"ENTRY",?30,"MR#",?38,"STATUS",?46,"REQUEST INFO"

 W !,"--------",?18,"-----",?30,"---",?38,"------",?46,"------------",!

 Q

PROCESS ;PROCESS LOOP FOR REPORT RECORDS

 ;DO SCREENING LOGIC - BUILD XTMP GLOBAL

 S ENTDAT=0

 F  S ENTDAT=$O(^AUPNRHI("G",ENTDAT)) Q:'+ENTDAT  D

 . Q:$P(ENTDAT,".",1)<BDT!($P(ENTDAT,".",1)>EDT)

 . S RHISTAT=""

 . F  S RHISTAT=$O(^AUPNRHI("G",ENTDAT,RHISTAT)) Q:RHISTAT=""  D

 .. S RHIREC=0

 .. F  S RHIREC=$O(^AUPNRHI("G",ENTDAT,RHISTAT,RHIREC)) Q:'+RHIREC  D

 ... S RECORD=$G(^AUPNRHI(RHIREC,0))

 ... S DFN=$P(RECORD,U)

 ... S MR=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)

 ... S RHI=$P(RECORD,U,2)

 ... S STREC=$S(RHISTAT="A":2,RHISTAT="P":1,RHISTAT="N":3,RHISTAT="R":4,RHISTAT="E":5)

 ... S USER=$S(STREC=1:$P($G(^AUPNRHI(RHIREC,STREC)),U,2),STREC=5:$P($G(^AUPNRHI(RHIREC,STREC)),U),1:$P($G(^AUPNRHI(RHIREC,STREC)),U,3))

 ... S ^XTMP("AGRHI",$J,ENTDAT,USER)=MR_U_RHISTAT_U_RHI

 K ENTDAT,RHIREC,RECORD,DFN,MR,RHISTAT,RHI,USER,STREC,BDT,EDT

 Q

PRINT ;DO HEADER AND DETAIL PRINTING HERE

 D HDR

 S (ENTDAT,USER,CNT)=0,RHIREC=""

 F  S ENTDAT=$O(^XTMP("AGRHI",$J,ENTDAT)) Q:'ENTDAT  D  Q:$G(AG("F1"))

 . F  S USER=$O(^XTMP("AGRHI",$J,ENTDAT,USER)) Q:'USER  D  Q:$G(AG("F1"))

 .. S RHIREC=$G(^XTMP("AGRHI",$J,ENTDAT,USER))

 .. S USERNAM=$P($G(^VA(200,USER,0)),U)

 .. S EDATE=$E(ENTDAT,4,5)_"/"_$E(ENTDAT,6,7)_"/"_($E(ENTDAT,1,3)+1700)

 .. S MR=$P(RHIREC,U)

 .. S STATUS=$P(RHIREC,U,2)

 .. S RHI=$P(RHIREC,U,3)

 .. I $Y>(IOSL-5) D HD Q:$G(AG("F1"))

 .. W !,USERNAM,?18,EDATE,?30,$$RJ^XLFSTR(MR,6),?40,STATUS

 .. S CNT=CNT+1

 .. S AG("Y")=$L(RHI)

 .. F  S AG("K")=$E(RHI,1,34) Q:$L(AG("K"))=0  S RHI=$E(RHI,35,AG("Y")) W ?46,AG("K"),!

 W !!,CNT," Records found from ",AG("BEGDT")," TO ",AG("ENDDT")

 Q

HD ;

 I '$D(IO("Q")),$E(IOST)="C",'$D(IO("S")) D

 . F  W ! Q:$Y+3>IOSL

 . K DIR S DIR(0)="E" D ^DIR K DIR

 I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) S AG("F1")=1

 D HDR

 Q

EXIT ;

 K ^XTMP("AGRHI",$J)

 Q

AGRHI1    ; IHS/ASDS/EFG - RESTRICTED HEALTH REPORT ;   

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2       ;

 +3       ;THIS ROUTINE WILL CREATE A REPORT BASED ON THE RESTIRCTED

 +4       ;HEALTH INFORMATION FILE

 +5       ;

 +6        QUIT 

EN        ;EP

 +1        KILL AG("F1")

 +2        DO BEGDT

 +3        IF $DATA(DTOUT)!$DATA(DUOUT)

               QUIT 

 +4        SET AGQ("RC")="PROCESS^AGRHI1"

 +5        SET AGQ("RP")="PRINT^AGRHI1"

 +6        SET AGQ("RX")="EXIT^AGRHI1"

 +7        SET AGQ("NS")="AG"

 +8        DO ^AGDBQUE

 +9        QUIT 

BEGDT     ;PROMPT FOR BEGINNING DATE OF ENTRY

 +1        SET AG("PAGE")=0

 +2        KILL DIR,X,Y

 +3        SET DIR(0)="D"

 +4        SET DIR("A")="Please enter a beginning Date Of Entry. "

 +5        DO ^DIR

 +6        IF $DATA(DTOUT)!$DATA(DUOUT)

               QUIT 

 +7        SET X=Y

           SET BDT=+Y

           DO DD^%DT

           SET AG("BEGDT")=Y

ENDDT     ;PROMPT FOR ENDING DATE OF ENTRY

 +1        KILL DIR,X,Y

 +2        SET DIR(0)="D"

 +3        SET DIR("A")="Please enter an ending Date Of Entry. "

 +4        DO ^DIR

 +5        IF $DATA(DTOUT)!$DATA(DUOUT)

               QUIT 

 +6        SET X=Y

           SET EDT=+Y

           DO DD^%DT

           SET AG("ENDDT")=Y

 +7        QUIT 

HDR       ;PRINT THE PAGE HEADER

 +1        WRITE @IOF

 +2        SET AG("PAGE")=AG("PAGE")+1

 +3        WRITE !,?19,"*** RESTRICTED HEALTH INFORMATION REPORT ***"

 +4        WRITE ?70,"Page ",AG("PAGE")

 +5        SET AG("RHIDT")=$$NOW^XLFDT

 +6        SET AG("DSPDAT")=$EXTRACT(AG("RHIDT"),4,5)_"/"_$EXTRACT(AG("RHIDT"),6,7)_"/"_($EXTRACT(AG("RHIDT"),1,3)+1700)_"  "_$EXTRACT(AG("RHIDT"),9,10)_":"_$EXTRACT(AG("RHIDT"),11,12)

 +7        SET AG("DSPDAT")="RUN DATE/TIME : "_AG("DSPDAT")

 +8        WRITE !,?(80-$LENGTH(AG("DSPDAT"))/2),AG("DSPDAT")

 +9        WRITE !!,"BEGINNING ENTRY DATE: ",AG("BEGDT")

 +10       WRITE !,"ENDING ENTRY DATE:    ",AG("ENDDT")

 +11       WRITE !!,"PERSON",?18,"DATE OF"

 +12       WRITE !,"ENTERING",?19,"ENTRY",?30,"MR#",?38,"STATUS",?46,"REQUEST INFO"

 +13       WRITE !,"--------",?18,"-----",?30,"---",?38,"------",?46,"------------",!

 +14       QUIT 

PROCESS   ;PROCESS LOOP FOR REPORT RECORDS

 +1       ;DO SCREENING LOGIC - BUILD XTMP GLOBAL

 +2        SET ENTDAT=0

 +3        FOR 

               SET ENTDAT=$ORDER(^AUPNRHI("G",ENTDAT))

               IF '+ENTDAT

                   QUIT 

               Begin DoDot:1

 +4                IF $PIECE(ENTDAT,".",1)<BDT!($PIECE(ENTDAT,".",1)>EDT)

                       QUIT 

 +5                SET RHISTAT=""

 +6                FOR 

                       SET RHISTAT=$ORDER(^AUPNRHI("G",ENTDAT,RHISTAT))

                       IF RHISTAT=""

                           QUIT 

                       Begin DoDot:2

 +7                        SET RHIREC=0

 +8                        FOR 

                               SET RHIREC=$ORDER(^AUPNRHI("G",ENTDAT,RHISTAT,RHIREC))

                               IF '+RHIREC

                                   QUIT 

                               Begin DoDot:3

 +9                                SET RECORD=$GET(^AUPNRHI(RHIREC,0))

 +10                               SET DFN=$PIECE(RECORD,U)

 +11                               SET MR=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)

 +12                               SET RHI=$PIECE(RECORD,U,2)

 +13                               SET STREC=$SELECT(RHISTAT="A":2,RHISTAT="P":1,RHISTAT="N":3,RHISTAT="R":4,RHISTAT="E":5)

 +14                               SET USER=$SELECT(STREC=1:$PIECE($GET(^AUPNRHI(RHIREC,STREC)),U,2),STREC=5:$PIECE($GET(^AUPNRHI(RHIREC,STREC)),U),1:$PIECE($GET(^AUPNRHI(RHIREC,STREC)),U,3))

 +15                               SET ^XTMP("AGRHI",$JOB,ENTDAT,USER)=MR_U_RHISTAT_U_RHI

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +16       KILL ENTDAT,RHIREC,RECORD,DFN,MR,RHISTAT,RHI,USER,STREC,BDT,EDT

 +17       QUIT 

PRINT     ;DO HEADER AND DETAIL PRINTING HERE

 +1        DO HDR

 +2        SET (ENTDAT,USER,CNT)=0

           SET RHIREC=""

 +3        FOR 

               SET ENTDAT=$ORDER(^XTMP("AGRHI",$JOB,ENTDAT))

               IF 'ENTDAT

                   QUIT 

               Begin DoDot:1

 +4                FOR 

                       SET USER=$ORDER(^XTMP("AGRHI",$JOB,ENTDAT,USER))

                       IF 'USER

                           QUIT 

                       Begin DoDot:2

 +5                        SET RHIREC=$GET(^XTMP("AGRHI",$JOB,ENTDAT,USER))

 +6                        SET USERNAM=$PIECE($GET(^VA(200,USER,0)),U)

 +7                        SET EDATE=$EXTRACT(ENTDAT,4,5)_"/"_$EXTRACT(ENTDAT,6,7)_"/"_($EXTRACT(ENTDAT,1,3)+1700)

 +8                        SET MR=$PIECE(RHIREC,U)

 +9                        SET STATUS=$PIECE(RHIREC,U,2)

 +10                       SET RHI=$PIECE(RHIREC,U,3)

 +11                       IF $Y>(IOSL-5)

                               DO HD

                               IF $GET(AG("F1"))

                                   QUIT 

 +12                       WRITE !,USERNAM,?18,EDATE,?30,$$RJ^XLFSTR(MR,6),?40,STATUS

 +13                       SET CNT=CNT+1

 +14                       SET AG("Y")=$LENGTH(RHI)

 +15                       FOR 

                               SET AG("K")=$EXTRACT(RHI,1,34)

                               IF $LENGTH(AG("K"))=0

                                   QUIT 

                               SET RHI=$EXTRACT(RHI,35,AG("Y"))

                               WRITE ?46,AG("K"),!

                       End DoDot:2

                       IF $GET(AG("F1"))

                           QUIT 

               End DoDot:1

               IF $GET(AG("F1"))

                   QUIT 

 +16       WRITE !!,CNT," Records found from ",AG("BEGDT")," TO ",AG("ENDDT")

 +17       QUIT 

HD        ;

 +1        IF '$DATA(IO("Q"))

               IF $EXTRACT(IOST)="C"

                   IF '$DATA(IO("S"))

                       Begin DoDot:1

 +2                        FOR 

                               WRITE !

                               IF $Y+3>IOSL

                                   QUIT 

 +3                        KILL DIR

                           SET DIR(0)="E"

                           DO ^DIR

                           KILL DIR

                       End DoDot:1

 +4        IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               SET AG("F1")=1

 +5        DO HDR

 +6        QUIT 

EXIT      ;

 +1        KILL ^XTMP("AGRHI",$JOB)

 +2        QUIT