AGPORT ;PCISPORT INITILIZATION ROUTINE [ 06/04/85 8:14 AM ]
;OCAO-IHS DRS
INIT D ^AUCLS
S UDEV=47,BDC=0,EFLG=0,EFLG=0,RUNADD=0,PATSAVE="",PATSKFLG=0,R15FLG=0,DUZ(0)="@"
S RWFLG=0 K ^REGCVTER,^COMERROR,^FACERROR
S X="TODAY" D ^%DT S DT=Y IF Y=-1 Q
F I=1:1:79 U 0 W "*"
QNTVAR I +^AQUAN(1,0)'=0 S (QT(2),QT(3),QT(4))="",QT(1)="FULL",QT(5)="NONE",QT(6)="UNSPECIFIED",QT(7)="UNKNOWN"
E S QT(0)="NONE",QT(8)="FULL",QT(9)="UNKNOWN" F I=1:1:7 S QT(I)=""
W !,?22,"PROGRAM TO PORT REGISTRATION DATA",!
W ?24,"OCAO RPMS DEVELOPMENT SITE",!
F I=1:1:79 U 0 W "*"
S TODAY=Y
I $D(^APAT(0))=1 G IADDMSG
G INITKILL
IADDMSG S TRECDS=$P(^APAT(0),"^",4)
I +TRECDS<1 G INITKILL
S MCRDFN=0 S:$D(^AMCR(0)) MCRDFN=$P(^AMCR(0),"^",3)
S MCDDFN=0 S:$D(^AMCD(0)) MCDDFN=$P(^AMCD(0),"^",3)
S RREDFN=0 S:$D(^ARRE(0)) RREDFN=$P(^ARRE(0),"^",3)
S MCRRCT=0 S:$D(^AMCR(0)) MCRRCT=$P(^AMCR(0),"^",4)
S MCDRCT=0 S:$D(^AMCD(0)) MCDRCT=$P(^AMCD(0),"^",4)
S RRERCT=0 S:$D(^ARRE(0)) RRERCT=$P(^ARRE(0),"^",4)
W !,"TOTAL PATIENTS RECORDS ON FILE =",TRECDS,!!
W !,"DO YOU WANT TO ADD TO THESE RECORDS (Y/N) "
U 0 R X
I $E(X)="Y" S RCT=TRECDS G STEP1
INITKILL U 0 R !,"I AM GOING TO KILL THE PATIENT FILES (Y/N) ??? ",X
I $E(X)'="Y" G JOBEND^AGPORTM
U 0 W !!,"ARE YOU SURE (YES/NO) "
U 0 R X
I X'="YES" G JOBEND^AGPORTM
K ^APAT,^AMCR,^ARRE,^AMCD,^APRVT,^DPT
S (RCT,MCRRCT,RRERCT,MCDRCT,MCDDFN,RREDFN,MCRDFN)=0
STEP1 S ^APAT(0)="IHS PATIENT^9000001IP",^DPT(0)="PATIENT^2"
O UDEV C UDEV O UDEV:("AFU":166:8134)
W !!,"DO YOU WANT TO REWIND TAPE (Y/N) "
U 0 R X
I X'="Y" G STEP1A
U UDEV W *5
STEP1A G ^AGPORTM
AUFLST ;TEST PROGRAM TO FIND LAST ENTRY IN GLOBAL
F DFN=1:1 S X=$O(^APAT(DFN)) Q:X'?.N
W !,"LAST # USED = ",DFN
Q
AGPORT ;PCISPORT INITILIZATION ROUTINE [ 06/04/85 8:14 AM ]
+1 ;OCAO-IHS DRS
INIT DO ^AUCLS
+1 SET UDEV=47
SET BDC=0
SET EFLG=0
SET EFLG=0
SET RUNADD=0
SET PATSAVE=""
SET PATSKFLG=0
SET R15FLG=0
SET DUZ(0)="@"
+2 SET RWFLG=0
KILL ^REGCVTER,^COMERROR,^FACERROR
+3 SET X="TODAY"
DO ^%DT
SET DT=Y
IF Y=-1
QUIT
+4 FOR I=1:1:79
USE 0
WRITE "*"
QNTVAR IF +^AQUAN(1,0)'=0
SET (QT(2),QT(3),QT(4))=""
SET QT(1)="FULL"
SET QT(5)="NONE"
SET QT(6)="UNSPECIFIED"
SET QT(7)="UNKNOWN"
+1 IF '$TEST
SET QT(0)="NONE"
SET QT(8)="FULL"
SET QT(9)="UNKNOWN"
FOR I=1:1:7
SET QT(I)=""
+2 WRITE !,?22,"PROGRAM TO PORT REGISTRATION DATA",!
+3 WRITE ?24,"OCAO RPMS DEVELOPMENT SITE",!
+4 FOR I=1:1:79
USE 0
WRITE "*"
+5 SET TODAY=Y
+6 IF $DATA(^APAT(0))=1
GOTO IADDMSG
+7 GOTO INITKILL
IADDMSG SET TRECDS=$PIECE(^APAT(0),"^",4)
+1 IF +TRECDS<1
GOTO INITKILL
+2 SET MCRDFN=0
IF $DATA(^AMCR(0))
SET MCRDFN=$PIECE(^AMCR(0),"^",3)
+3 SET MCDDFN=0
IF $DATA(^AMCD(0))
SET MCDDFN=$PIECE(^AMCD(0),"^",3)
+4 SET RREDFN=0
IF $DATA(^ARRE(0))
SET RREDFN=$PIECE(^ARRE(0),"^",3)
+5 SET MCRRCT=0
IF $DATA(^AMCR(0))
SET MCRRCT=$PIECE(^AMCR(0),"^",4)
+6 SET MCDRCT=0
IF $DATA(^AMCD(0))
SET MCDRCT=$PIECE(^AMCD(0),"^",4)
+7 SET RRERCT=0
IF $DATA(^ARRE(0))
SET RRERCT=$PIECE(^ARRE(0),"^",4)
+8 WRITE !,"TOTAL PATIENTS RECORDS ON FILE =",TRECDS,!!
+9 WRITE !,"DO YOU WANT TO ADD TO THESE RECORDS (Y/N) "
+10 USE 0
READ X
+11 IF $EXTRACT(X)="Y"
SET RCT=TRECDS
GOTO STEP1
INITKILL USE 0
READ !,"I AM GOING TO KILL THE PATIENT FILES (Y/N) ??? ",X
+1 IF $EXTRACT(X)'="Y"
GOTO JOBEND^AGPORTM
+2 USE 0
WRITE !!,"ARE YOU SURE (YES/NO) "
+3 USE 0
READ X
+4 IF X'="YES"
GOTO JOBEND^AGPORTM
+5 KILL ^APAT,^AMCR,^ARRE,^AMCD,^APRVT,^DPT
+6 SET (RCT,MCRRCT,RRERCT,MCDRCT,MCDDFN,RREDFN,MCRDFN)=0
STEP1 SET ^APAT(0)="IHS PATIENT^9000001IP"
SET ^DPT(0)="PATIENT^2"
+1 OPEN UDEV
CLOSE UDEV
OPEN UDEV:("AFU":166:8134)
+2 WRITE !!,"DO YOU WANT TO REWIND TAPE (Y/N) "
+3 USE 0
READ X
+4 IF X'="Y"
GOTO STEP1A
+5 USE UDEV
WRITE *5
STEP1A GOTO ^AGPORTM
AUFLST ;TEST PROGRAM TO FIND LAST ENTRY IN GLOBAL
+1 +2 FOR DFN=1:1
SET X=$ORDER(^APAT(DFN))
IF X'?.N
QUIT
+3 WRITE !,"LAST # USED = ",DFN
+4 QUIT
